Flame Graph
Data
| C:\Eliot\GitHub\NetLogoR/R/turtle-functions.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| ################################################################################ | ||||||||
| #' Create turtles | ||||||||
| #' | ||||||||
| #' Create \code{n} turtles with a set of defined variables. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param coords Matrix (ncol = 2) with the first column "xcor" and the second | ||||||||
| #' column "ycor" representing the turtles inital locations. | ||||||||
| #' \code{nrow(coords)} must be equal to 1 or to \code{n}. | ||||||||
| #' Given coordinates must be inside the \code{world}'s extent. If missing, | ||||||||
| #' turtles are put in the center of the \code{world}. | ||||||||
| #' | ||||||||
| #' @param heading Numeric. Vector of values between 0 and 360. Must be of length 1 or | ||||||||
| #' of length \code{n}. If missing, a random heading is assigned to | ||||||||
| #' each turtle. | ||||||||
| #' | ||||||||
| #' @param breed Character. Vector of "breed" names. Must be of length 1 or of length | ||||||||
| #' \code{n}. If missing, \code{breed = "turtle"} for all turtles. | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame of length \code{n} with the columns for the | ||||||||
| #' dataframe being: "who", "heading", "prevX", "prevY", "breed", and "color". | ||||||||
| #' | ||||||||
| #' @details If \code{coords} is provided, \code{world} must not be provided. | ||||||||
| #' | ||||||||
| #' The identity of the turtles is defined by their "who" number. This | ||||||||
| #' numbering starts at 0 and increments by 1. | ||||||||
| #' | ||||||||
| #' The coordinates from the previous time step are stored in "prevX" and | ||||||||
| #' "prevY". The initial values are \code{NA}. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = runif(count(patches(w1)))) | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10)) | ||||||||
| #' | ||||||||
| #' library(SpaDES) | ||||||||
| #' clearPlot() | ||||||||
| #' Plot(w1) | ||||||||
| #' Plot(t1, addTo ="w1") # automatically uses color column in SpatialPointsDataFrame | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname createTurtles | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "createTurtles", | ||||||||
| function(n, coords, world, heading, breed, color) { | ||||||||
| standardGeneric("createTurtles") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname createTurtles | ||||||||
| setMethod( | ||||||||
| "createTurtles", | ||||||||
| signature = c("numeric", "matrix", "missing", "ANY", "ANY", "ANY"), | ||||||||
| definition = function(n, coords, world, heading, breed, color) { | ||||||||
| li <- lapply(names(match.call()[-1]), function(x) eval(parse(text=x))) | ||||||||
| names(li) <- names(match.call())[-1] | ||||||||
| if(nrow(li$coords) == 1){ | ||||||||
| li$coords <- cbind(xcor = as.numeric(rep(li$coords[,1], n)), ycor = as.numeric(rep(li$coords[,2], n))) | ||||||||
| } | ||||||||
| if(missing(heading)) | ||||||||
| li$heading <- runif(n = n, min = 0, max = 360) | ||||||||
| if(length(li$heading) == 1){ | ||||||||
| li$heading <- rep(li$heading, n) | ||||||||
| } | ||||||||
| if(missing(breed)) | ||||||||
| li$breed <- rep("turtle", n) | ||||||||
| if(length(li$breed) == 1){ | ||||||||
| li$breed <- rep(li$breed, n) | ||||||||
| } | ||||||||
| if(missing(color)) | ||||||||
| li$color <- rainbow(n) | ||||||||
| turtles<-SpatialPointsDataFrame(coords = li$coords, | ||||||||
| data = data.frame(who = seq(from = 0, to = n - 1, by = 1), | ||||||||
| heading = li$heading, | ||||||||
| prevX = rep(NA, n), | ||||||||
| prevY = rep(NA, n), | ||||||||
| breed = li$breed, | ||||||||
| color = li$color, | ||||||||
| stringsAsFactors=FALSE)) | ||||||||
| return(turtles) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname createTurtles | ||||||||
| setMethod( | ||||||||
| "createTurtles", | ||||||||
| signature = c("numeric", "missing", "NLworlds", "ANY", "ANY", "ANY"), | ||||||||
| definition = function(n, coords, world, heading, breed, color) { | ||||||||
| li <- lapply(names(match.call()[-1]), function(x) eval(parse(text=x))) | ||||||||
| names(li) <- names(match.call())[-1] | ||||||||
| if(missing(heading)) | ||||||||
| li$heading <- runif(n = n, min = 0, max = 360) | ||||||||
| if(length(li$heading) == 1){ | ||||||||
| li$heading <- rep(li$heading, n) | ||||||||
| } | ||||||||
| if(missing(breed)) | ||||||||
| li$breed <- rep("turtle", n) | ||||||||
| if(length(li$breed) == 1){ | ||||||||
| li$breed <- rep(li$breed, n) | ||||||||
| } | ||||||||
| if(missing(color)) | ||||||||
| li$color <- rainbow(n) | ||||||||
| coords <- cbind(xcor = rep((((world@extent@xmax - world@extent@xmin) / 2) + world@extent@xmin), n), | ||||||||
| ycor = rep((((world@extent@ymax - world@extent@ymin) / 2) + world@extent@ymin), n)) | ||||||||
| createTurtles(n = n, coords = coords, heading = li$heading, breed = li$breed, color = li$color) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Create ordered turtles | ||||||||
| #' | ||||||||
| #' Create \code{n} turtles at the center of the \code{world} with their headings evenly | ||||||||
| #' distributed. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @inheritParams createTurtles | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame of length \code{n} with the columns for the | ||||||||
| #' dataframe being: "who", "heading", "prevX", "prevY", "breed", and "color". | ||||||||
| #' | ||||||||
| #' @details The identity of the turtles is defined by their "who" number. This | ||||||||
| #' numbering starts at 0 and increments by 1. | ||||||||
| #' | ||||||||
| #' The coordinates from the previous time step are stored in "prevX" and | ||||||||
| #' "prevY". The initial values are \code{NA}. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-ordered-turtles} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = runif(count(patches(w1)))) | ||||||||
| #' t1 <- createOTurtles(n = 10, world = w1) | ||||||||
| #' | ||||||||
| #' library(SpaDES) | ||||||||
| #' clearPlot() | ||||||||
| #' Plot(w1) | ||||||||
| #' Plot(t1, addTo ="w1") # automatically uses color column in SpatialPointsDataFrame | ||||||||
| #' | ||||||||
| #' t1 <- fd(turtles = t1, dist = 1) | ||||||||
| #' Plot(t1, addTo ="w1") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname createOTurtles | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "createOTurtles", | ||||||||
| function(n, world, breed, color) { | ||||||||
| standardGeneric("createOTurtles") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname createOTurtles | ||||||||
| setMethod( | ||||||||
| "createOTurtles", | ||||||||
| signature = c(n = "numeric", world = "NLworlds"), | ||||||||
| definition = function(n, world, breed, color) { | ||||||||
| heading <- numeric(n) | ||||||||
| heading[1] <- 0 | ||||||||
| if(n > 1) { | ||||||||
| heading[2:n] <- heading[1:(n-1)] + (360 / n) * (1:(n - 1)) | ||||||||
| } | ||||||||
| li <- lapply(names(match.call()[-1]), function(x) eval(parse(text=x))) | ||||||||
| names(li) <- names(match.call())[-1] | ||||||||
| if(missing(breed)) | ||||||||
| li$breed <- rep("turtle", n) | ||||||||
| if(length(li$breed) == 1){ | ||||||||
| li$breed <- rep(li$breed, n) | ||||||||
| } | ||||||||
| if(missing(color)) | ||||||||
| li$color <- rainbow(n) | ||||||||
| createTurtles(n = n, world = world, heading = heading, breed = li$breed, color = li$color) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Move forward | ||||||||
| #' | ||||||||
| #' Move the \code{turtles} forward with their headings as directions. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param dist Numeric. Vector of distances to move. Must | ||||||||
| #' be of length 1 or of length \code{turtles}. | ||||||||
| #' | ||||||||
| #' @param out Logical. Determine if a turtle should move when | ||||||||
| #' \code{torus = FALSE} and its ending position will be outside of | ||||||||
| #' the \code{world}'s extent. Default is \code{out = TRUE}. | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame representing the \code{turtles} with updated | ||||||||
| #' coordinates and updated data for their previous coordinates "prevX" | ||||||||
| #' and "prevY". | ||||||||
| #' | ||||||||
| #' @details If \code{torus = FALSE} and \code{out = TRUE}, \code{world} | ||||||||
| #' does not need to be provided. | ||||||||
| #' | ||||||||
| #' If a distance to move leads a turtle outside of the \code{world}'s extent | ||||||||
| #' and \code{torus = TRUE}, the turtle is | ||||||||
| #' relocated on the other side of the \code{world}, inside its extent; if | ||||||||
| #' \code{torus = FALSE} and \code{out = TRUE}, the turtle moves past the | ||||||||
| #' \code{world}'s extent; if \code{torus = FALSE} and \code{out = FALSE}, the | ||||||||
| #' turtle does not move at all. In the event that a turtle does not move, | ||||||||
| #' its previous coordinates are still updated with its position before | ||||||||
| #' running \code{fd()} (i.e., its current position). | ||||||||
| #' | ||||||||
| #' If a given \code{dist} value is negative, then the turtle moves | ||||||||
| #' backward. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#forward} | ||||||||
| #' | ||||||||
| #' \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#jump} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = runif(count(patches(w1)))) | ||||||||
| #' t1 <- createOTurtles(world = w1, n = 10) | ||||||||
| #' | ||||||||
| #' library(SpaDES) | ||||||||
| #' clearPlot() | ||||||||
| #' Plot(w1) | ||||||||
| #' Plot(t1, addTo ="w1") | ||||||||
| #' | ||||||||
| #' t1 <- fd(turtles = t1, dist = 1) | ||||||||
| #' Plot(t1, addTo ="w1") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @importFrom CircStats rad | ||||||||
| #' @importFrom SpaDES wrap | ||||||||
| #' @docType methods | ||||||||
| #' @rdname fd | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "fd", | ||||||||
| function(turtles, dist, world, torus = FALSE, out = TRUE) { | ||||||||
| standardGeneric("fd") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname fd | ||||||||
| setMethod( | ||||||||
| "fd", | ||||||||
| signature = c(turtles = "SpatialPointsDataFrame", dist = "numeric"), | ||||||||
| definition = function(turtles, dist, world, torus, out) { | ||||||||
| prevXcor <- turtles@coords[,1] | ||||||||
| prevYcor <- turtles@coords[,2] | ||||||||
| turtles@data$prevX <- prevXcor | ||||||||
| turtles@data$prevY <- prevYcor | ||||||||
| fdXcor <- prevXcor + sin(rad(turtles@data$heading)) * dist | ||||||||
| fdYcor <- prevYcor + cos(rad(turtles@data$heading)) * dist | ||||||||
| if(torus == TRUE){ | ||||||||
| if(missing(world)){ | ||||||||
| stop("A world must be provided as torus = TRUE") | ||||||||
| } | ||||||||
| tCoords <- wrap(cbind(x = fdXcor, y = fdYcor), extent(world)) | ||||||||
| fdXcor <- tCoords[,1] | ||||||||
| fdYcor <- tCoords[,2] | ||||||||
| } | ||||||||
| if(torus == FALSE & out == FALSE){ | ||||||||
| if(missing(world)){ | ||||||||
| stop("A world must be provided as torus = FALSE and out = FALSE") | ||||||||
| } | ||||||||
| outX <- fdXcor < world@extent@xmin | fdXcor > world@extent@xmax | ||||||||
| outY <- fdYcor < world@extent@ymin | fdYcor > world@extent@ymax | ||||||||
| outXY <- which(outX | outY) # position of turtles out of the world's extent | ||||||||
| fdXcor[outXY] <- prevXcor[outXY] | ||||||||
| fdYcor[outXY] <- prevYcor[outXY] | ||||||||
| } | ||||||||
| turtles@coords <- cbind(xcor = round(fdXcor, digits = 5), ycor = round(fdYcor, digits = 5)) | ||||||||
| return(turtles) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Move backward | ||||||||
| #' | ||||||||
| #' Move the \code{turtles} backward of their headings' directions. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @inheritParams fd | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame representing the \code{turtles} with updated | ||||||||
| #' coordinates and updated data for their previous coordinates "prevX" | ||||||||
| #' and "prevY". | ||||||||
| #' | ||||||||
| #' @details If \code{torus = FALSE} and \code{out = TRUE}, \code{world} | ||||||||
| #' does not need to be provided. | ||||||||
| #' | ||||||||
| #' If a distance to move leads a turtle outside of the \code{world}'s extent | ||||||||
| #' and \code{torus = TRUE}, the turtle is | ||||||||
| #' relocated on the other side of the \code{world}, inside its extent; if | ||||||||
| #' \code{torus = FALSE} and \code{out = TRUE}, the turtle moves past the | ||||||||
| #' \code{world}'s extent; if \code{torus = FALSE} and \code{out = FALSE}, the | ||||||||
| #' turtle does not move at all. In the event that a turtle does not move, | ||||||||
| #' its previous coordinates are still updated with its position before | ||||||||
| #' running \code{bk()} (i.e., its current position). | ||||||||
| #' | ||||||||
| #' If a given \code{dist} value is negative, then the turtle moves | ||||||||
| #' forward. | ||||||||
| #' | ||||||||
| #' The \code{turtles}' headings are not affected by the function (i.e., the | ||||||||
| #' \code{turtles} do not face backward). | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#back} | ||||||||
| #' | ||||||||
| #' \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#jump} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = runif(count(patches(w1)))) | ||||||||
| #' t1 <- createOTurtles(world = w1, n = 10) | ||||||||
| #' | ||||||||
| #' library(SpaDES) | ||||||||
| #' clearPlot() | ||||||||
| #' Plot(w1) | ||||||||
| #' Plot(t1, addTo ="w1") | ||||||||
| #' | ||||||||
| #' t1 <- fd(turtles = t1, dist = 2) | ||||||||
| #' Plot(t1, addTo ="w1") | ||||||||
| #' t1 <- bk(turtles = t1, dist = 1) | ||||||||
| #' Plot(t1, addTo ="w1") | ||||||||
| #' t1 <- fd(turtles = t1, dist = 0.5) | ||||||||
| #' Plot(t1, addTo ="w1") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname bk | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "bk", | ||||||||
| function(turtles, dist, world, torus = FALSE, out = TRUE) { | ||||||||
| standardGeneric("bk") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname bk | ||||||||
| setMethod( | ||||||||
| "bk", | ||||||||
| signature = c(turtles = "SpatialPointsDataFrame", dist = "numeric"), | ||||||||
| definition = function(turtles, dist, world, torus, out) { | ||||||||
| fd(turtles = turtles, dist = -dist, world = world, torus = torus, out = out) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Return home | ||||||||
| #' | ||||||||
| #' Move the \code{turtles} back \code{home}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param home Character. Can take one of the following options to define where | ||||||||
| #' to relocate the \code{turtles}: | ||||||||
| #' | ||||||||
| #' \code{home = "home0"} will place the \code{turtles} at the location | ||||||||
| #' \code{x = 0, y = 0}. | ||||||||
| #' | ||||||||
| #' \code{home = "center"} will place the \code{turtles} at the center of | ||||||||
| #' the \code{world}. | ||||||||
| #' | ||||||||
| #' \code{home = "pCorner"} will place the \code{turtles} at the center of | ||||||||
| #' the patch located in the left bottom corner of the \code{world}. | ||||||||
| #' | ||||||||
| #' \code{home = "corner"} will place the \code{turtles} at the left bottom | ||||||||
| #' corner of the \code{world}. | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame representing the \code{turtles} with updated | ||||||||
| #' coordinates and updated data for their previous coordinates "prevX" | ||||||||
| #' and "prevY". | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#home} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = runif(count(patches(w1)))) | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10)) | ||||||||
| #' | ||||||||
| #' library(SpaDES) | ||||||||
| #' clearPlot() | ||||||||
| #' Plot(w1) | ||||||||
| #' Plot(t1, addTo ="w1") | ||||||||
| #' | ||||||||
| #' t1 <- home(world = w1, turtles = t1, home = "pCorner") | ||||||||
| #' Plot(t1, addTo ="w1") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname home | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "home", | ||||||||
| function(world, turtles, home) { | ||||||||
| standardGeneric("home") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname home | ||||||||
| setMethod( | ||||||||
| "home", | ||||||||
| signature = c("NLworlds", "SpatialPointsDataFrame", "character"), | ||||||||
| definition = function(world, turtles, home) { | ||||||||
| if(home == "home0"){ | ||||||||
| if(world@extent@xmin <= 0 & world@extent@xmax >= 0 & world@extent@ymin <= 0 & world@extent@ymax >= 0){ | ||||||||
| newTurtles<- setXY(turtles = turtles, xcor = 0, ycor = 0, world = world, torus = FALSE) | ||||||||
| } else { | ||||||||
| stop("The world provided does not contain the location [x = 0, y = 0]") | ||||||||
| } | ||||||||
| } | ||||||||
| if(home == "center"){ | ||||||||
| newTurtles<- setXY(turtles = turtles, xcor = (((world@extent@xmax - world@extent@xmin) / 2) + world@extent@xmin), | ||||||||
| ycor = (((world@extent@ymax - world@extent@ymin) / 2) + world@extent@ymin), | ||||||||
| world = world, torus = FALSE) | ||||||||
| } | ||||||||
| if(home == "pCorner"){ | ||||||||
| newTurtles<- setXY(turtles = turtles, xcor = minPxcor(world), ycor = minPycor(world), world = world, torus = FALSE) | ||||||||
| } | ||||||||
| if(home == "corner"){ | ||||||||
| newTurtles<- setXY(turtles = turtles, xcor = world@extent@xmin, ycor = world@extent@ymin, world = world, torus = FALSE) | ||||||||
| } | ||||||||
| return(newTurtles) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' x-increment | ||||||||
| #' | ||||||||
| #' Report the amount by which the \code{turtles}' coordinates xcor would change | ||||||||
| #' if the \code{turtles} were | ||||||||
| #' to move forward the given distances with their current headings. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param dist Numeric. Vector of distances the \code{turtles} would have to | ||||||||
| #' move forward to | ||||||||
| #' compute the increment values. Must be of length 1 or of length | ||||||||
| #' \code{turtles}. The default value is \code{dist = 1}. | ||||||||
| #' | ||||||||
| #' @return Numeric. Vector of length \code{turtles}. | ||||||||
| #' | ||||||||
| #' @details Report the sine of the \code{turtles}' heading multiplied by the \code{dist} | ||||||||
| #' values. Heading 0 is north and angles are calculated in degrees in a | ||||||||
| #' clockwise manner. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#dxy} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' t1 <- createOTurtles(world = w1, n = 10) | ||||||||
| #' dx(turtles = t1) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @importFrom CircStats rad | ||||||||
| #' @docType methods | ||||||||
| #' @rdname dx | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "dx", | ||||||||
| function(turtles, dist = 1) { | ||||||||
| standardGeneric("dx") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname dx | ||||||||
| setMethod( | ||||||||
| "dx", | ||||||||
| signature = c("SpatialPointsDataFrame", "numeric"), | ||||||||
| definition = function(turtles, dist) { | ||||||||
| xIncr <- round(sin(rad(turtles@data$heading)) * dist, digits = 5) | ||||||||
| return(xIncr) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname dx | ||||||||
| setMethod( | ||||||||
| "dx", | ||||||||
| signature = c("SpatialPointsDataFrame", "missing"), | ||||||||
| definition = function(turtles) { | ||||||||
| dx(turtles = turtles, dist = 1) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' y-increment | ||||||||
| #' | ||||||||
| #' Report the amount by which the \code{turtles}' coordinates ycor would change | ||||||||
| #' if the \code{turtles} were | ||||||||
| #' to move forward the given distances with their current headings. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @inheritParams dx | ||||||||
| #' | ||||||||
| #' @return Numeric. Vector of length \code{turtles}. | ||||||||
| #' | ||||||||
| #' @details Report the cosine of the \code{turtles}' heading multiplied by the \code{dist} | ||||||||
| #' values. Heading 0 is north and angles are calculated in degrees in a | ||||||||
| #' clockwise manner. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#dxy} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' t1 <- createOTurtles(world = w1, n = 10) | ||||||||
| #' dy(turtles = t1) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @importFrom CircStats rad | ||||||||
| #' @docType methods | ||||||||
| #' @rdname dy | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "dy", | ||||||||
| function(turtles, dist = 1) { | ||||||||
| standardGeneric("dy") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname dy | ||||||||
| setMethod( | ||||||||
| "dy", | ||||||||
| signature = c("SpatialPointsDataFrame", "numeric"), | ||||||||
| definition = function(turtles, dist) { | ||||||||
| yIncr <- round(cos(rad(turtles@data$heading)) * dist, digits = 5) | ||||||||
| return(yIncr) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname dy | ||||||||
| setMethod( | ||||||||
| "dy", | ||||||||
| signature = c("SpatialPointsDataFrame", "missing"), | ||||||||
| definition = function(turtles) { | ||||||||
| dy(turtles = turtles, dist = 1) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Kill turtles | ||||||||
| #' | ||||||||
| #' Kill selected turtles. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame representing the \code{turtles} with the selected | ||||||||
| #' ones removed. | ||||||||
| #' | ||||||||
| #' @details The "who" numbers of the remaining \code{turtles} are unchanged. | ||||||||
| #' | ||||||||
| #' To remove all the \code{turtles}, you can use \code{clearTurtles()}. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#die} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' t1 <- createTurtles(n = 10, world = w1) | ||||||||
| #' count(t1) | ||||||||
| #' t1 <- die(turtles = t1, who = c(2, 3, 4)) | ||||||||
| #' count(t1) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname die | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "die", | ||||||||
| function(turtles, who) { | ||||||||
| standardGeneric("die") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname die | ||||||||
| setMethod( | ||||||||
| "die", | ||||||||
| signature = c("SpatialPointsDataFrame", "numeric"), | ||||||||
| definition = function(turtles, who) { | ||||||||
| whoTurtles <- turtles@data$who | ||||||||
| toSelect <- whoTurtles[which(!whoTurtles %in% who)] | ||||||||
| if(length(toSelect) == 0){ | ||||||||
| newTurtles <- noTurtles() | ||||||||
| } else { | ||||||||
| newTurtles <- turtle(turtles, toSelect) | ||||||||
| } | ||||||||
| return(newTurtles) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Hatch new turtles | ||||||||
| #' | ||||||||
| #' Create \code{n} new turtles for each parent turtle. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param breed Character. One "breed" name. If missing, | ||||||||
| #' the created turtles are of the same "breed" as their parent turtle. | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame representing the \code{turtles} with the new | ||||||||
| #' hatched ones. | ||||||||
| #' | ||||||||
| #' @details The parent turtle must be contained in the \code{turtles}. | ||||||||
| #' | ||||||||
| #' The created turtles inherit of all the data from the parent turtle, | ||||||||
| #' except for the "breed" if specified otherwise, and for the "who" numbers. | ||||||||
| #' The "who" numbers of the turtles created take on following the highest | ||||||||
| #' "who" number among the \code{turtles}. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#hatch} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' t1 <- createTurtles(n = 10, world = w1) | ||||||||
| #' count(t1) | ||||||||
| #' t1 <- hatch(turtles = t1, who = 0, n = 2) | ||||||||
| #' count(t1) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname hatch | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "hatch", | ||||||||
| function(turtles, who, n, breed) { | ||||||||
| standardGeneric("hatch") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname hatch | ||||||||
| setMethod( | ||||||||
| "hatch", | ||||||||
| signature = c("SpatialPointsDataFrame", "numeric", "numeric", "ANY"), | ||||||||
| definition = function(turtles, who, n, breed) { | ||||||||
| iTurtle <- match(who, turtles@data$who) | ||||||||
| parentCoords <- turtles@coords[iTurtle,] | ||||||||
| parentData <- turtles@data[iTurtle,] | ||||||||
| if(length(iTurtle) == 1){ # parentCoords is numeric | ||||||||
| newCoords <- rbind(turtles@coords, cbind(xcor = rep(as.numeric(parentCoords[1]), n), ycor = rep(as.numeric(parentCoords[2]), n))) | ||||||||
| } else { # parentCoords is a matrix | ||||||||
| newCoords <- rbind(turtles@coords, cbind(xcor = rep(as.numeric(parentCoords[,1]), each = n), ycor = rep(as.numeric(parentCoords[,2]), each = n))) | ||||||||
| } | ||||||||
| newData <- rbind(turtles@data, parentData[rep(seq_len(nrow(parentData)), each = n),]) | ||||||||
| rownames(newData) <- seq_len(nrow(newData)) | ||||||||
| # Update the who numbers and breed | ||||||||
| newData[(nrow(turtles) + 1):nrow(newData), "who"] <- (max(turtles@data$who) + 1):(max(turtles@data$who) + (n * length(iTurtle))) | ||||||||
| if(!missing(breed)){ | ||||||||
| newData[(nrow(turtles) + 1):nrow(newData), "breed"] <- breed | ||||||||
| } | ||||||||
| newTurtles <- SpatialPointsDataFrame(coords = newCoords, data = newData) | ||||||||
| return(newTurtles) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Can the turtles move? | ||||||||
| #' | ||||||||
| #' Report \code{TRUE} if a turtle can move the given distance without leaving | ||||||||
| #' the \code{world}'s extent, report \code{FALSE} otherwise. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @inheritParams fd | ||||||||
| #' | ||||||||
| #' @return Logical. Vector of length \code{turtles}. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#can-move} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' t1 <- createTurtles(n = 10, world = w1) | ||||||||
| #' canMove(world = w1, turtles = t1, dist = 1:10) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname canMove | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "canMove", | ||||||||
| function(world, turtles, dist) { | ||||||||
| standardGeneric("canMove") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname canMove | ||||||||
| setMethod( | ||||||||
| "canMove", | ||||||||
| signature = c("NLworlds", "SpatialPointsDataFrame", "numeric"), | ||||||||
| definition = function(world, turtles, dist) { | ||||||||
| wrapFalse <- fd(world = world, turtles = turtles, dist = dist, torus = FALSE) | ||||||||
| wrapTrue <- fd(world = world, turtles = turtles, dist = dist, torus = TRUE) | ||||||||
| test <- wrapFalse@coords == wrapTrue@coords | ||||||||
| return(test[,1] & test[,2]) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Random xcor | ||||||||
| #' | ||||||||
| #' Report \code{n} random xcor coordinates within the \code{world}'s extent. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Numeric. Vector of length \code{n} of xcor coordinates. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = runif(count(patches(w1)))) | ||||||||
| #' t1 <- createTurtles(n = 10,coords = cbind(xcor = randomXcor(world = w1, n = 10), | ||||||||
| #' ycor = randomYcor(world = w1, n = 10))) | ||||||||
| #' library(SpaDES) | ||||||||
| #' clearPlot() | ||||||||
| #' Plot(w1) | ||||||||
| #' Plot(t1, addTo = "w1") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname randomXcor | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "randomXcor", | ||||||||
| function(world, n) { | ||||||||
| standardGeneric("randomXcor") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname randomXcor | ||||||||
| setMethod( | ||||||||
| "randomXcor", | ||||||||
| signature = c("NLworlds", "numeric"), | ||||||||
| definition = function(world, n) { | ||||||||
| if(n == 0){ | ||||||||
| return(xcor = numeric()) | ||||||||
| } else { | ||||||||
| xmin <- world@extent@xmin | ||||||||
| xmax <- world@extent@xmax | ||||||||
| xcor <- round(runif(n = n, min = xmin, max = xmax), digits = 5) | ||||||||
| return(xcor) | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Random ycor | ||||||||
| #' | ||||||||
| #' Report \code{n} random ycor coordinates within the \code{world}'s extent. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Numeric. Vector of length \code{n} of ycor coordinates. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = runif(count(patches(w1)))) | ||||||||
| #' t1 <- createTurtles(n = 10, coords = cbind(xcor = randomXcor(world = w1, n = 10), | ||||||||
| #' ycor = randomYcor(world = w1, n = 10))) | ||||||||
| #' library(SpaDES) | ||||||||
| #' clearPlot() | ||||||||
| #' Plot(w1) | ||||||||
| #' Plot(t1, addTo = "w1") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname randomYcor | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "randomYcor", | ||||||||
| function(world, n) { | ||||||||
| standardGeneric("randomYcor") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname randomYcor | ||||||||
| setMethod( | ||||||||
| "randomYcor", | ||||||||
| signature = c("NLworlds", "numeric"), | ||||||||
| definition = function(world, n) { | ||||||||
| if(n == 0){ | ||||||||
| return(ycor = numeric()) | ||||||||
| } else { | ||||||||
| ymin <- world@extent@ymin | ||||||||
| ymax <- world@extent@ymax | ||||||||
| ycor <- round(runif(n = n, min = ymin, max = ymax), digits = 5) | ||||||||
| return(ycor) | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Directions towards | ||||||||
| #' | ||||||||
| #' Report the directions of each \code{agents} towards each corresponding \code{agents2}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Numeric. Vector of angles in degrees of length equal to the largest | ||||||||
| #' number of agents/locations between \code{agents} and \code{agents2}. | ||||||||
| #' | ||||||||
| #' @details \code{agents} and \code{agents2} must have the same number of agents/locations | ||||||||
| #' or if different, one of them must have only one agent/location. If | ||||||||
| #' \code{agents} and \code{agents2} have the same number of agents/locations, | ||||||||
| #' the directions are calculated for each pair \code{agents[i]} and \code{agents2[i]} | ||||||||
| #' and not for each \code{agents} towards all the \code{agents2}. | ||||||||
| #' | ||||||||
| #' If \code{torus = FALSE}, \code{world} does not need to be provided. | ||||||||
| #' | ||||||||
| #' If \code{torus = TRUE} and the distance from one \code{agents} to | ||||||||
| #' its corresponding \code{agents2} is smaller around the | ||||||||
| #' sides of the \code{world} than across it, then the direction to \code{agents2} | ||||||||
| #' going around the sides of the \code{world} is returned. | ||||||||
| #' | ||||||||
| #' The direction from a patch to its location returns 0; the direction from | ||||||||
| #' a turtle to its location returns the turtle's heading. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#towards} | ||||||||
| #' | ||||||||
| #' \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#towardsxy} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' towards(agents = patches(w1), agents2 = cbind(x = 0, y = 0)) | ||||||||
| #' t1 <- createTurtles(n = 10, world = w1) | ||||||||
| #' towards(agents = t1, agents2 = cbind(x = 0, y = 0)) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @importFrom CircStats deg | ||||||||
| #' @docType methods | ||||||||
| #' @rdname towards | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "towards", | ||||||||
| function(agents, agents2, world, torus = FALSE) { | ||||||||
| standardGeneric("towards") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname towards | ||||||||
| setMethod( | ||||||||
| "towards", | ||||||||
| signature = c(agents = "matrix", agents2 = "matrix"), | ||||||||
| definition = function(agents, agents2, world, torus) { | ||||||||
| if(torus == FALSE){ | ||||||||
| heading <- deg(atan2(agents2[,1] - agents[,1], agents2[,2] - agents[,2])) # angles between -180 and 180 | ||||||||
| heading[heading < 0] <- heading[heading < 0] + 360 | ||||||||
| } else { | ||||||||
| if(missing(world)){ | ||||||||
| stop("A world must be provided as torus = TRUE") | ||||||||
| } | ||||||||
| if(nrow(agents2) == 1 & nrow(agents) != 1){ | ||||||||
| agents2 <- cbind(x = rep(agents2[,1], nrow(agents)), y = rep(agents2[,2], nrow(agents))) | ||||||||
| } | ||||||||
| if(nrow(agents) == 1 & nrow(agents2) != 1){ | ||||||||
| agents <- cbind(x = rep(agents[,1], nrow(agents2)), y = rep(agents[,2], nrow(agents2))) | ||||||||
| } | ||||||||
| # Need to create coordinates for "agents2" in a wrapped world | ||||||||
| # For all the 8 possibilities of wrapping (to the left, right, top, bottom and 4 corners) | ||||||||
| # Find the smallest distances across or around the world | ||||||||
| to1 <- cbind(agents2[,1] - (world@extent@xmax - world@extent@xmin), agents2[,2] + (world@extent@ymax - world@extent@ymin)) | ||||||||
| to2 <- cbind(agents2[,1], agents2[,2] + (world@extent@ymax - world@extent@ymin)) | ||||||||
| to3 <- cbind(agents2[,1] + (world@extent@xmax - world@extent@xmin), agents2[,2] + (world@extent@ymax - world@extent@ymin)) | ||||||||
| to4 <- cbind(agents2[,1] - (world@extent@xmax - world@extent@xmin), agents2[,2]) | ||||||||
| to5 <- cbind(agents2[,1] + (world@extent@xmax - world@extent@xmin), agents2[,2]) | ||||||||
| to6 <- cbind(agents2[,1] - (world@extent@xmax - world@extent@xmin), agents2[,2] - (world@extent@ymax - world@extent@ymin)) | ||||||||
| to7 <- cbind(agents2[,1], agents2[,2] - (world@extent@ymax - world@extent@ymin)) | ||||||||
| to8 <- cbind(agents2[,1] + (world@extent@xmax - world@extent@xmin), agents2[,2] - (world@extent@ymax - world@extent@ymin)) | ||||||||
| # All distances in a wrapped world | ||||||||
| dist_agents2 <- pointDistance(p1 = agents, p2 = agents2, lonlat = FALSE, allpairs = FALSE) | ||||||||
| dist_to1 <- pointDistance(p1 = agents, p2 = to1, lonlat = FALSE, allpairs = FALSE) | ||||||||
| dist_to2 <- pointDistance(p1 = agents, p2 = to2, lonlat = FALSE, allpairs = FALSE) | ||||||||
| dist_to3 <- pointDistance(p1 = agents, p2 = to3, lonlat = FALSE, allpairs = FALSE) | ||||||||
| dist_to4 <- pointDistance(p1 = agents, p2 = to4, lonlat = FALSE, allpairs = FALSE) | ||||||||
| dist_to5 <- pointDistance(p1 = agents, p2 = to5, lonlat = FALSE, allpairs = FALSE) | ||||||||
| dist_to6 <- pointDistance(p1 = agents, p2 = to6, lonlat = FALSE, allpairs = FALSE) | ||||||||
| dist_to7 <- pointDistance(p1 = agents, p2 = to7, lonlat = FALSE, allpairs = FALSE) | ||||||||
| dist_to8 <- pointDistance(p1 = agents, p2 = to8, lonlat = FALSE, allpairs = FALSE) | ||||||||
| # Which distance is the minimum | ||||||||
| allDist <- cbind(dist_agents2, dist_to1, dist_to2, dist_to3, dist_to4, dist_to5, dist_to6, dist_to7, dist_to8) | ||||||||
| distMin <- apply(allDist, 1, min) | ||||||||
| toShortest <- agents2 | ||||||||
| for(i in 1:nrow(agents)){ | ||||||||
| # All the possibilities for each agents (i.e., agents2 and the wrapped agents2) | ||||||||
| allToCoords <- rbind(agents2[i,], to1[i,], to2[i,], to3[i,], to4[i,], to5[i,], to6[i,], to7[i,], to8[i,]) | ||||||||
| toShortest[i,] <- allToCoords[match(distMin[i], allDist[i,]),] # if ties, take the first match (good because favor the non wrapped distances) | ||||||||
| } | ||||||||
| heading <- deg(atan2(toShortest[,1] - agents[,1], toShortest[,2] - agents[,2])) # angles between -180 and 180 | ||||||||
| heading[heading < 0] <- heading[heading < 0] + 360 | ||||||||
| } | ||||||||
| return(heading) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname towards | ||||||||
| setMethod( | ||||||||
| "towards", | ||||||||
| signature = c(agents = "SpatialPointsDataFrame", agents2 = "matrix"), | ||||||||
| definition = function(agents, agents2, world, torus) { | ||||||||
| heading <- towards(agents = agents@coords, agents2 = agents2, world = world, torus = torus) | ||||||||
| # The direction to a turtle's location return the turtle's heading | ||||||||
| heading <- ifelse(agents@coords[,1] == agents2[,1] & agents@coords[,2] == agents2[,2], agents@data$heading, heading) | ||||||||
| return(heading) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname towards | ||||||||
| setMethod( | ||||||||
| "towards", | ||||||||
| signature = c(agents = "matrix", agents2 = "SpatialPointsDataFrame"), | ||||||||
| definition = function(agents, agents2, world, torus) { | ||||||||
| towards(agents = agents, agents2 = agents2@coords, world = world, torus = torus) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname towards | ||||||||
| setMethod( | ||||||||
| "towards", | ||||||||
| signature = c(agents = "SpatialPointsDataFrame", agents2 = "SpatialPointsDataFrame"), | ||||||||
| definition = function(agents, agents2, world, torus) { | ||||||||
| heading <- towards(agents = agents@coords, agents2 = agents2@coords, world = world, torus = torus) | ||||||||
| # The direction to a turtle's location return the turtle's heading | ||||||||
| heading <- ifelse(agents@coords[,1] == agents2@coords[,1] & agents@coords[,2] == agents2@coords[,2], agents@data$heading, heading) | ||||||||
| return(heading) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Face something | ||||||||
| #' | ||||||||
| #' Set the \code{turtles}' heading towards \code{agents2}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame representing the \code{turtles} with updated headings. | ||||||||
| #' | ||||||||
| #' @details The number of agents/locations in \code{agents2} must be equal to 1 or | ||||||||
| #' to the length of \code{turtles}. | ||||||||
| #' | ||||||||
| #' If \code{torus = FALSE}, \code{world} does not need to be provided. | ||||||||
| #' | ||||||||
| #' If \code{torus = TRUE} and the distance from one \code{turtles} to | ||||||||
| #' its corresponding agent/location \code{agents2} is smaller around the | ||||||||
| #' sides of the \code{world} than across it, then the direction to the agent/location | ||||||||
| #' \code{agents2} going around the sides of the \code{world} is given to the turtle. | ||||||||
| #' | ||||||||
| #' If a turtle is facing its own location, its heading does not change. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#face} | ||||||||
| #' | ||||||||
| #' \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#facexy} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = runif(count(patches(w1)))) | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10)) | ||||||||
| #' | ||||||||
| #' library(SpaDES) | ||||||||
| #' clearPlot() | ||||||||
| #' Plot(w1) | ||||||||
| #' Plot(t1, addTo = "w1") | ||||||||
| #' | ||||||||
| #' t1 <- face(turtles = t1, agents2 = cbind(x = 0, y = 0)) | ||||||||
| #' t1 <- fd(turtles = t1, dist = 0.5) | ||||||||
| #' Plot(t1, addTo = "w1") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname face | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "face", | ||||||||
| function(turtles, agents2, world, torus = FALSE) { | ||||||||
| standardGeneric("face") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname face | ||||||||
| setMethod( | ||||||||
| "face", | ||||||||
| signature = c(turtles = "SpatialPointsDataFrame", agents2 = "matrix"), | ||||||||
| definition = function(turtles, agents2, world, torus) { | ||||||||
| newHeading <- towards(agents = turtles, agents2 = agents2, world = world, torus = torus) | ||||||||
| turtles@data$heading <- newHeading | ||||||||
| return(turtles) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname face | ||||||||
| setMethod( | ||||||||
| "face", | ||||||||
| signature = c(turtles = "SpatialPointsDataFrame", agents2 = "SpatialPointsDataFrame"), | ||||||||
| definition = function(turtles, agents2, world, torus) { | ||||||||
| face(turtles = turtles, agents2 = agents2@coords, world = world, torus = torus) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Rotate to the left | ||||||||
| #' | ||||||||
| #' Rotate the \code{turtles}'s headings to the left of \code{angle} degrees. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param angle Numeric. Vector of angles in degrees by which to rotate the \code{turtles}' | ||||||||
| #' headings. Must be of length 1 or of length \code{turtles}. | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame representing the \code{turtles} with updated "heading" values. | ||||||||
| #' | ||||||||
| #' @details If a given \code{angle} value is negative, then the turtle rotates to the right. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#left} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' t1 <- createTurtles(n = 10, world = w1) | ||||||||
| #' of(agents = t1, var = "heading") | ||||||||
| #' t1 <- left(turtles = t1, angle = 180) | ||||||||
| #' of(agents = t1, var = "heading") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname left | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "left", | ||||||||
| function(turtles, angle) { | ||||||||
| standardGeneric("left") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname left | ||||||||
| setMethod( | ||||||||
| "left", | ||||||||
| signature = c("SpatialPointsDataFrame", "numeric"), | ||||||||
| definition = function(turtles, angle) { | ||||||||
| newHeading <- turtles@data$heading - angle | ||||||||
| newHeading[newHeading < 0] <- newHeading[newHeading < 0] + 360 | ||||||||
| newHeading[newHeading >= 360] <- newHeading[newHeading >= 360] - 360 | ||||||||
| turtles@data$heading <- newHeading | ||||||||
| return(turtles) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Rotate to the right | ||||||||
| #' | ||||||||
| #' Rotate the \code{turtles}'s headings to the right of \code{angle} degrees. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @inheritParams left | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame representing the \code{turtles} with updated "heading" values. | ||||||||
| #' | ||||||||
| #' @details If a given \code{angle} value is negative, then the turtle rotates to the left. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#right} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' t1 <- createTurtles(n = 10, world = w1) | ||||||||
| #' of(agents = t1, var = "heading") | ||||||||
| #' t1 <- right(turtles = t1, angle = 180) | ||||||||
| #' of(agents = t1, var = "heading") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname right | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "right", | ||||||||
| function(turtles, angle) { | ||||||||
| standardGeneric("right") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname right | ||||||||
| setMethod( | ||||||||
| "right", | ||||||||
| signature = c("SpatialPointsDataFrame", "numeric"), | ||||||||
| definition = function(turtles, angle) { | ||||||||
| left(turtles = turtles, angle = -angle) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Move downhill | ||||||||
| #' | ||||||||
| #' Move the \code{turtles} to their neighboring patch with the lowest value. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame representing the \code{turtles} with updated | ||||||||
| #' coordinates and updated data for their "heading" values and | ||||||||
| #' previous coordinates "prevX" | ||||||||
| #' and "prevY". | ||||||||
| #' | ||||||||
| #' @details If no neighboring patch has a smaller value than the patch where the | ||||||||
| #' turtle is currently located on, the turtle stays on this patch. It still | ||||||||
| #' moves to the patch center if it was not already on it. | ||||||||
| #' | ||||||||
| #' If there are multiple neighboring patches with the same lowest value, | ||||||||
| #' the turtle chooses one patch randomly. | ||||||||
| #' | ||||||||
| #' If a turtle is located on a patch on the edge | ||||||||
| #' of the \code{world} and \code{torus = FALSE}, it has fewer | ||||||||
| #' neighborhing patches as options to move than \code{nNeighbors}; if | ||||||||
| #' \code{torus = TRUE}, the turtle can move on the other side of the \code{world} to | ||||||||
| #' move downhill and its choice of neighborhing patches is always equals to | ||||||||
| #' \code{nNeighbors}. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#downhill} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 1, maxPxcor = 10, minPycor = 1, maxPycor = 10) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = runif(count(patches(w1)))) | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10)) | ||||||||
| #' | ||||||||
| #' library(SpaDES) | ||||||||
| #' clearPlot() | ||||||||
| #' Plot(w1) | ||||||||
| #' Plot(t1, addTo = "w1") | ||||||||
| #' | ||||||||
| #' t1 <- downhill(world = w1, turtles = t1, nNeighbors = 8) | ||||||||
| #' Plot(t1, addTo = "w1") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @importFrom data.table rbindlist | ||||||||
| #' @importFrom car some | ||||||||
| #' @docType methods | ||||||||
| #' @rdname downhill | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "downhill", | ||||||||
| function(world, pVar, turtles, nNeighbors, torus = FALSE) { | ||||||||
| standardGeneric("downhill") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname downhill | ||||||||
| setMethod( | ||||||||
| "downhill", | ||||||||
| signature = c(world = "NLworld", pVar = "missing",turtles = "SpatialPointsDataFrame", nNeighbors = "numeric"), | ||||||||
| definition = function(world, turtles, nNeighbors, torus) { | ||||||||
| # ## Output neighbors() as a list | ||||||||
| # pNeighbors <- neighbors(world = world, agents = turtles, nNeighbors = nNeighbors, torus = torus) | ||||||||
| # pValues <- values(world) # ordered by cellNumbers | ||||||||
| # | ||||||||
| # pListDF <- lapply(pNeighbors, as.data.frame) | ||||||||
| # pDF <- as.data.frame(rbindlist(pListDF)) # faster than do.call(rbind, ...) | ||||||||
| # pDF$id <- rep(1:length(turtles), unlist(lapply(pNeighbors, nrow))) | ||||||||
| # tDF <- data.frame(patchHere(world, turtles), id = 1:length(turtles)) | ||||||||
| # allPatches <- rbind(pDF, tDF) # neighbors patches + patches under the turtles | ||||||||
| # ## | ||||||||
| ## Output neighbors() as a matrix | ||||||||
| pNeighbors <- neighbors(world = world, agents = turtles, nNeighbors = nNeighbors, torus = torus) | ||||||||
| pValues <- values(world) # ordered by cellNumbers | ||||||||
| tDF <- data.frame(patchHere(world, turtles), id = 1:length(turtles)) | ||||||||
| allPatches <- rbind(pNeighbors, tDF) # neighbors patches + patches under the turtles | ||||||||
| ## | ||||||||
| allPatches$cellNum <- cellFromPxcorPycor(world = world, pxcor = allPatches$pxcor, pycor = allPatches$pycor) | ||||||||
| allPatches$pVal <- pValues[allPatches$cellNum] | ||||||||
| # Slow | ||||||||
| # pMin <- aggregate(pVal ~ id, allPatches, function(x) min(x)) # minimum patch value per id | ||||||||
| # pMinCoords <- merge(pMin, allPatches) | ||||||||
| # pMinCoords1 <- pMinCoords[tapply(1:nrow(pMinCoords), pMinCoords$id, some, 1),] # select randomly one row per id | ||||||||
| # pMinCoords1 <- pMinCoords1[order(pMinCoords1$id),] # order by turtles | ||||||||
| # pMinCoords2 <- cbind(pxcor = pMinCoords1[,3], pycor = pMinCoords1[,4]) | ||||||||
| # Faster | ||||||||
| rows <- split(1:nrow(allPatches), allPatches$id) | ||||||||
| rowMin <- sapply(rows, function(rowi) {rowi[which.min(allPatches$pVal[rowi])]}) # minimum patch value per id | ||||||||
| pMinCoords <- allPatches[rowMin,] | ||||||||
| pMinCoords1 <- pMinCoords[tapply(1:nrow(pMinCoords), pMinCoords$id, some, 3),] # select randomly one row per id | ||||||||
| pMinCoords1 <- pMinCoords1[order(pMinCoords1$id),] # order by turtles | ||||||||
| pMinCoords2 <- cbind(pxcor = pMinCoords1[,1], pycor = pMinCoords1[,2]) | ||||||||
| newTurtles <- face(world = world, turtles = turtles, agents2 = pMinCoords2, torus = torus) | ||||||||
| newTurtles <- moveTo(turtles = newTurtles, agents = pMinCoords2) | ||||||||
| return(newTurtles) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname downhill | ||||||||
| setMethod( | ||||||||
| "downhill", | ||||||||
| signature = c(world = "NLworldStack", pVar = "character",turtles = "SpatialPointsDataFrame", nNeighbors = "numeric"), | ||||||||
| definition = function(world, pVar, turtles, nNeighbors, torus) { | ||||||||
| pos_l <- which(names(world) == pVar, TRUE) # find the layer | ||||||||
| world_l <- world[[pos_l]] | ||||||||
| downhill(world = world_l, turtles = turtles, nNeighbors = nNeighbors, torus = torus) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Move uphill | ||||||||
| #' | ||||||||
| #' Move the \code{turtles} to their neighboring patch with the highest value. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame representing the \code{turtles} with updated | ||||||||
| #' coordinates and updated data for their "heading" values and | ||||||||
| #' previous coordinates "prevX" | ||||||||
| #' and "prevY". | ||||||||
| #' | ||||||||
| #' @details If no neighboring patch has a larger value than the patch where the | ||||||||
| #' turtle is currently located on, the turtle stays on this patch. It still | ||||||||
| #' moves to the patch center if it was not already on it. | ||||||||
| #' | ||||||||
| #' If there are multiple neighboring patches with the same highest value, | ||||||||
| #' the turtle chooses one patch randomly. | ||||||||
| #' | ||||||||
| #' If a turtle is located on a patch on the edge | ||||||||
| #' of the \code{world} and \code{torus = FALSE}, it has fewer | ||||||||
| #' neighborhing patches as options to move than \code{nNeighbors}; if | ||||||||
| #' \code{torus = TRUE}, the turtle can move on the other side of the \code{world} to | ||||||||
| #' move uphill and its choice of neighborhing patches is always equals to | ||||||||
| #' \code{nNeighbors}. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#uphill} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 1, maxPxcor = 10, minPycor = 1, maxPycor = 10) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = runif(count(patches(w1)))) | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10)) | ||||||||
| #' | ||||||||
| #' library(SpaDES) | ||||||||
| #' clearPlot() | ||||||||
| #' Plot(w1) | ||||||||
| #' Plot(t1, addTo = "w1") | ||||||||
| #' | ||||||||
| #' t1 <- uphill(world = w1, turtles = t1, nNeighbors = 8) | ||||||||
| #' Plot(t1, addTo = "w1") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname uphill | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "uphill", | ||||||||
| function(world, pVar, turtles, nNeighbors, torus = FALSE) { | ||||||||
| standardGeneric("uphill") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname uphill | ||||||||
| setMethod( | ||||||||
| "uphill", | ||||||||
| signature = c(world = "NLworld", pVar = "missing",turtles = "SpatialPointsDataFrame", nNeighbors = "numeric"), | ||||||||
| definition = function(world, turtles, nNeighbors, torus) { | ||||||||
| # Uphill is the inverse of downhill | ||||||||
| worldInv <- world | ||||||||
| worldInv[] <- 1 / values(world) | ||||||||
| downhill(world = worldInv, turtles = turtles, nNeighbors = nNeighbors, torus = torus) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname uphill | ||||||||
| setMethod( | ||||||||
| "uphill", | ||||||||
| signature = c(world = "NLworldStack", pVar = "character",turtles = "SpatialPointsDataFrame", nNeighbors = "numeric"), | ||||||||
| definition = function(world, pVar, turtles, nNeighbors, torus) { | ||||||||
| pos_l <- which(names(world) == pVar, TRUE) # find the layer | ||||||||
| world_l <- world[[pos_l]] | ||||||||
| uphill(world = world_l, turtles = turtles, nNeighbors = nNeighbors, torus = torus) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Patches ahead | ||||||||
| #' | ||||||||
| #' Report the coordinates of the patches at the given | ||||||||
| #' distances of the \code{turtles} in the direction of their headings. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param dist Numeric. Vector of distances from the \code{turtles}. \code{dist} must be | ||||||||
| #' of length 1 or of length \code{turtles}. | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2) with the first column "pxcor" and the second column | ||||||||
| #' "pycor" representing the coordinates of the patches at the distances \code{dist} | ||||||||
| #' and \code{turtles}'s headings directions | ||||||||
| #' of \code{turtles}. The order of the patches follows the order of the \code{turtles}. | ||||||||
| #' | ||||||||
| #' @details If \code{torus = FALSE} and the patch at distance \code{dist} of a turtle | ||||||||
| #' is outside the \code{world}'s extent, \code{NA} | ||||||||
| #' are returned for the patch coordinates. If \code{torus = TRUE}, the patch | ||||||||
| #' coordinates from a wrapped \code{world} are returned. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#patch-ahead} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10)) | ||||||||
| #' patchAhead(world = w1, turtles = t1, dist = 1) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @importFrom CircStats rad | ||||||||
| #' @docType methods | ||||||||
| #' @rdname patchAhead | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "patchAhead", | ||||||||
| function(world, turtles, dist, torus = FALSE) { | ||||||||
| standardGeneric("patchAhead") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname patchAhead | ||||||||
| setMethod( | ||||||||
| "patchAhead", | ||||||||
| signature = c(world = "NLworlds", turtles = "SpatialPointsDataFrame", dist = "numeric"), | ||||||||
| definition = function(world, turtles, dist, torus) { | ||||||||
| xcor <- round(turtles@coords[,1] + sin(rad(turtles@data$heading)) * dist, digits = 5) | ||||||||
| ycor <- round(turtles@coords[,2] + cos(rad(turtles@data$heading)) * dist, digits = 5) | ||||||||
| pAhead <- patch(world = world, x = xcor, y = ycor, duplicate = TRUE, torus = torus, out = TRUE) | ||||||||
| return(pAhead) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Patches here | ||||||||
| #' | ||||||||
| #' Report the coordinates of the patches under the \code{turtles} | ||||||||
| #' locations. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2) with the first column "pxcor" and the second column | ||||||||
| #' "pycor" representing the coordinates of the patches at the \code{turtles} | ||||||||
| #' location. The order of the patches follows the order of the \code{turtles}. | ||||||||
| #' | ||||||||
| #' @details If a turtle is located outside of the \code{world}'s extent, \code{NA} are returned | ||||||||
| #' for the patch coordinates. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#patch-here} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10)) | ||||||||
| #' patchHere(world = w1, turtles = t1) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname patchHere | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "patchHere", | ||||||||
| function(world, turtles) { | ||||||||
| standardGeneric("patchHere") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname patchHere | ||||||||
| setMethod( | ||||||||
| "patchHere", | ||||||||
| signature = c("NLworlds", "SpatialPointsDataFrame"), | ||||||||
| definition = function(world, turtles) { | ||||||||
| pTurtles <- patch(world = world, x = turtles@coords[,1], y = turtles@coords[,2], duplicate = TRUE, out = TRUE) | ||||||||
| return(pTurtles) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Patches on the left | ||||||||
| #' | ||||||||
| #' Report the coordinates of the patches at the given distances of the \code{turtles} | ||||||||
| #' on the left of their headings. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @inheritParams patchAhead | ||||||||
| #' | ||||||||
| #' @param angle Numeric. Vector of angles in degrees by which the \code{turtle}'s | ||||||||
| #' headings should rotate to locate the patches. Must be of length 1 or of | ||||||||
| #' length \code{turtles}. | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2) with the first column "pxcor" and the second | ||||||||
| #' column "pycor" representing the coordinates of the patches at \code{dist} | ||||||||
| #' distances of the \code{turtles} and \code{angle} to the left of their headings. | ||||||||
| #' The order of the patches follows the order of the \code{turtles}. | ||||||||
| #' | ||||||||
| #' @details If a given \code{dist} value is negative, then the turtle would move backward. | ||||||||
| #' If a given \code{angle} value is negative, then the turtle would rotate to the right. | ||||||||
| #' | ||||||||
| #' If \code{torus = FALSE} and the patch at distance \code{dist} of a turtle | ||||||||
| #' and \code{angle} degrees to the left of its heading is outside the \code{world}'s extent, \code{NA} | ||||||||
| #' are returned for the patch coordinates. If \code{torus = TRUE}, the patch | ||||||||
| #' coordinates from a wrapped \code{world} are returned. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#patch-lr-and-ahead} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' t1 <- createTurtles(n = 1, coords = cbind(xcor = 2, ycor = 2), heading = 90) | ||||||||
| #' patchLeft(world = w1, turtles = t1, dist = 2, angle = 90) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname patchLeft | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "patchLeft", | ||||||||
| function(world, turtles, dist, angle, torus = FALSE) { | ||||||||
| standardGeneric("patchLeft") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname patchLeft | ||||||||
| setMethod( | ||||||||
| "patchLeft", | ||||||||
| signature = c(world = "NLworlds", turtles = "SpatialPointsDataFrame", dist = "numeric", angle = "numeric"), | ||||||||
| definition = function(world, turtles, dist, angle, torus) { | ||||||||
| tLeft <- left(turtles = turtles, angle = angle) | ||||||||
| tFd <- fd(world = world, turtles = tLeft, dist = dist, torus = torus) | ||||||||
| pLeftFd <- patchHere(world = world, turtles = tFd) | ||||||||
| return(pLeftFd) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Patches on the right | ||||||||
| #' | ||||||||
| #' Report the coordinates of the patches at the given distances of the \code{turtles} | ||||||||
| #' on the right of their headings. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @inheritParams patchLeft | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2) with the first column "pxcor" and the second | ||||||||
| #' column "pycor" representing the coordinates of the patches at \code{dist} | ||||||||
| #' distances of the \code{turtles} and \code{angle} to the right of their headings. | ||||||||
| #' The order of the patches follows the order of the \code{turtles}. | ||||||||
| #' | ||||||||
| #' @details If a given \code{dist} value is negative, then the turtle would move backward. | ||||||||
| #' If a given \code{angle} value is negative, then the turtle would rotate to the left. | ||||||||
| #' | ||||||||
| #' If \code{torus = FALSE} and the patch at distance \code{dist} of a turtle | ||||||||
| #' and \code{angle} degrees to the right of its heading is outside the \code{world}'s extent, \code{NA} | ||||||||
| #' are returned for the patch coordinates. If \code{torus = TRUE}, the patch | ||||||||
| #' coordinates from a wrapped \code{world} are returned. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#patch-lr-and-ahead} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' t1 <- createTurtles(n = 1, coords = cbind(xcor = 2, ycor = 2), heading = 90) | ||||||||
| #' patchRight(world = w1, turtles = t1, dist = 2, angle = 90) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname patchRight | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "patchRight", | ||||||||
| function(world, turtles, dist, angle, torus = FALSE) { | ||||||||
| standardGeneric("patchRight") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname patchRight | ||||||||
| setMethod( | ||||||||
| "patchRight", | ||||||||
| signature = c(world = "NLworlds", turtles = "SpatialPointsDataFrame", dist = "numeric", angle = "numeric"), | ||||||||
| definition = function(world, turtles, dist, angle, torus) { | ||||||||
| patchLeft(world = world, turtles = turtles, dist = dist, angle = -angle, torus = torus) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Set turtles' locations | ||||||||
| #' | ||||||||
| #' Set the turtles \code{xcor} and \code{ycor} coordinates. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param xcor Numeric. Vector of x coordinates. Must be of length 1 or | ||||||||
| #' of length \code{turtles}. | ||||||||
| #' | ||||||||
| #' @param ycor Numeric. Vector of y coordinates. Must be of length 1 or | ||||||||
| #' of length \code{turtles}. | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame representing the \code{turtles} with updated coordinates | ||||||||
| #' and updated data for their previous coordinates "prevX" and "prevY" | ||||||||
| #' | ||||||||
| #' @details \code{world} must be provided if only if \code{torus = TRUE}. | ||||||||
| #' | ||||||||
| #' If the given coordinates \code{[xcor, ycor]} | ||||||||
| #' are located outside of the \code{world}'s extent and \code{torus = TRUE}, | ||||||||
| #' then the coordinates assigned to the turtle | ||||||||
| #' are the ones from a wrapped \code{word}; if \code{torus = FALSE}, the turtle | ||||||||
| #' is located outside of the \code{world}'s extent with the given coordinates. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#setxy} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = runif(count(patches(w1)))) | ||||||||
| #' t1 <- createTurtles(n = 5, coords = randomXYcor(w1, n = 5)) | ||||||||
| #' | ||||||||
| #' library(SpaDES) | ||||||||
| #' clearPlot() | ||||||||
| #' Plot(w1) | ||||||||
| #' Plot(t1, addTo ="w1") | ||||||||
| #' | ||||||||
| #' t1 <- setXY(turtles = t1, xcor = 1:5, ycor = 1:5) | ||||||||
| #' Plot(t1, addTo ="w1") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname setXY | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "setXY", | ||||||||
| function(turtles, xcor, ycor, world, torus = FALSE) { | ||||||||
| standardGeneric("setXY") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname setXY | ||||||||
| setMethod( | ||||||||
| "setXY", | ||||||||
| signature = c("SpatialPointsDataFrame", "numeric", "numeric", "missing", "ANY"), | ||||||||
| definition = function(turtles, xcor, ycor, torus) { | ||||||||
| turtles@data$prevX <- turtles@coords[,1] | ||||||||
| turtles@data$prevY <- turtles@coords[,2] | ||||||||
| if(length(xcor) == 1 & length(turtles) != 1){ | ||||||||
| xcor <- as.numeric(rep(xcor, length(turtles))) | ||||||||
| } | ||||||||
| if(length(ycor) == 1 & length(turtles) != 1){ | ||||||||
| ycor <- as.numeric(rep(ycor, length(turtles))) | ||||||||
| } | ||||||||
| turtles@coords <- cbind(xcor, ycor) | ||||||||
| return(turtles) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @importFrom SpaDES wrap | ||||||||
| #' @rdname setXY | ||||||||
| setMethod( | ||||||||
| "setXY", | ||||||||
| signature = c("SpatialPointsDataFrame", "numeric", "numeric", "NLworlds", "logical"), | ||||||||
| definition = function(turtles, xcor, ycor, world, torus) { | ||||||||
| wrapCoords <- wrap(cbind(x = xcor, y = ycor), extent(world)) | ||||||||
| setXY(turtles = turtles, xcor = wrapCoords[,1], ycor = wrapCoords[,2], torus = FALSE) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Sprout new turtles | ||||||||
| #' | ||||||||
| #' Create \code{n} new turtles on specific \code{patches}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @inheritParams createTurtles | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame including the new | ||||||||
| #' sprouted turtles. | ||||||||
| #' | ||||||||
| #' @details \code{nrow(patches)} must be equal to 1 or to \code{n}. | ||||||||
| #' | ||||||||
| #' If \code{turtles} is provided, the new turtles are added to | ||||||||
| #' the \code{turtles} when returned. The who numbers of the sprouted turtles | ||||||||
| #' therefore follow the ones from the \code{turtles}. If no \code{turtles} | ||||||||
| #' is provided, a new SpatialPointsDataFrame is created and the who numbers | ||||||||
| #' start at 0. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#sprout} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' t1 <- sprout(patches = cbind(pxcor = 2, pycor = 2), n = 3) | ||||||||
| #' t2 <- sprout(patches = cbind(pxcor = 3, pycor = 3), n = 3, turtles = t1) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname sprout | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "sprout", | ||||||||
| function(n, patches, breed, heading, color, turtles) { | ||||||||
| standardGeneric("sprout") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname sprout | ||||||||
| setMethod( | ||||||||
| "sprout", | ||||||||
| signature = c(n = "numeric", patches = "matrix"), | ||||||||
| definition = function(n, patches, breed, heading, color, turtles) { | ||||||||
| li <- lapply(names(match.call()[-1]), function(x) eval(parse(text=x))) | ||||||||
| names(li) <- names(match.call())[-1] | ||||||||
| if(nrow(li$patches) == 1 & n != 1){ | ||||||||
| li$patches <- cbind(as.numeric(rep(li$patches[,1], n)), as.numeric(rep(li$patches[,2], n))) | ||||||||
| } | ||||||||
| colnames(li$patches) <- c("xcor", "ycor") | ||||||||
| if(missing(breed)) | ||||||||
| li$breed <- rep("turtle", n) | ||||||||
| if(length(li$breed) == 1){ | ||||||||
| li$breed <- rep(li$breed, n) | ||||||||
| } | ||||||||
| if(missing(heading)) | ||||||||
| li$heading <- runif(n = n, min = 0, max = 360) | ||||||||
| if(length(li$heading) == 1){ | ||||||||
| li$heading <- rep(li$heading, n) | ||||||||
| } | ||||||||
| if(missing(color)) | ||||||||
| li$color <- rainbow(n) | ||||||||
| newTurtles <- createTurtles(n = n, coords = li$patches, heading = li$heading, breed = li$breed, color = li$color) | ||||||||
| if(missing(turtles)){ | ||||||||
| return(newTurtles) | ||||||||
| } else { | ||||||||
| newTurtles@data$who <- (max(turtles@data$who) + 1):(n + max(turtles@data$who)) # unique who number | ||||||||
| newColor <- rainbow(n + length(turtles)) | ||||||||
| newTurtles@data$color <- sample(newColor[! newColor %in% turtles@data$color], n) # unique color | ||||||||
| bothTurtles <- SpatialPointsDataFrame(coords = rbind(turtles@coords, newTurtles@coords), | ||||||||
| data = rbind(turtles@data, newTurtles@data)) | ||||||||
| return(bothTurtles) | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Inspect turtles | ||||||||
| #' | ||||||||
| #' Display the variables values for the selected individuals among the \code{turtles}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Dataframe (nrow = \code{length(who)}) with the variables for the selected | ||||||||
| #' individuals among the \code{turtles}. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#inspect} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' t1 <- createOTurtles(world = w1, n = 10) | ||||||||
| #' inspect(turtles = t1, who = c(2, 3)) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname inspect | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "inspect", | ||||||||
| function(turtles, who) { | ||||||||
| standardGeneric("inspect") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname inspect | ||||||||
| setMethod( | ||||||||
| "inspect", | ||||||||
| signature = c("SpatialPointsDataFrame", "numeric"), | ||||||||
| definition = function(turtles, who) { | ||||||||
| tData <- cbind(turtles[turtles$who %in% who,]@data, turtles[turtles$who %in% who,]@coords) | ||||||||
| return(tData) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Move to | ||||||||
| #' | ||||||||
| #' Move the \code{turtles} to the \code{agents}' locations. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame representing the \code{turtles} with updated coordinates | ||||||||
| #' and updated data for their previous coordinates "prevX" and "prevY". | ||||||||
| #' | ||||||||
| #' @details The number of \code{agents} must be equal to 1 or to | ||||||||
| #' length \code{turtles}. | ||||||||
| #' | ||||||||
| #' The \code{turtle}'s headings are not affected with this function. | ||||||||
| #' | ||||||||
| #' If a turtle is moving to a patch location, it will be located at | ||||||||
| #' the patch center. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#move-to} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = runif(count(patches(w1)))) | ||||||||
| #' t1 <- createTurtles(n = 5, coords = randomXYcor(w1, n = 5)) | ||||||||
| #' | ||||||||
| #' library(SpaDES) | ||||||||
| #' clearPlot() | ||||||||
| #' Plot(w1) | ||||||||
| #' Plot(t1, addTo ="w1") | ||||||||
| #' | ||||||||
| #' t1 <- moveTo(turtles = t1, agents = turtle(t1, who = 0)) | ||||||||
| #' Plot(t1, addTo ="w1") | ||||||||
| #' t1 <- moveTo(turtles = t1, agents = patch(w1, 9, 9)) | ||||||||
| #' Plot(t1, addTo ="w1") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname moveTo | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "moveTo", | ||||||||
| function(turtles, agents) { | ||||||||
| standardGeneric("moveTo") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname moveTo | ||||||||
| setMethod( | ||||||||
| "moveTo", | ||||||||
| signature = c("SpatialPointsDataFrame", "matrix"), | ||||||||
| definition = function(turtles, agents) { | ||||||||
| setXY(turtles = turtles, xcor = as.numeric(agents[,1]), ycor = as.numeric(agents[,2]), torus = FALSE) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname moveTo | ||||||||
| setMethod( | ||||||||
| "moveTo", | ||||||||
| signature = c("SpatialPointsDataFrame", "SpatialPointsDataFrame"), | ||||||||
| definition = function(turtles, agents) { | ||||||||
| moveTo(turtles = turtles, agents = agents@coords) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Random turtles coordinates | ||||||||
| #' | ||||||||
| #' Report \code{n} random xcor and ycor coordinates within the \code{world}'s extent. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2, nrow = \code{n}) with the first column "xcor" and the second | ||||||||
| #' column "ycor". | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = runif(count(patches(w1)))) | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(world = w1, n = 10)) | ||||||||
| #' | ||||||||
| #' library(SpaDES) | ||||||||
| #' clearPlot() | ||||||||
| #' Plot(w1) | ||||||||
| #' Plot(t1, addTo = "w1") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname randomXYcor | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "randomXYcor", | ||||||||
| function(world, n) { | ||||||||
| standardGeneric("randomXYcor") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname randomXYcor | ||||||||
| setMethod( | ||||||||
| "randomXYcor", | ||||||||
| signature = c("NLworlds", "numeric"), | ||||||||
| definition = function(world, n) { | ||||||||
| xycor <- cbind(xcor = randomXcor(world = world, n = n), ycor = randomYcor(world = world, n = n)) | ||||||||
| return(xycor) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Do the turtles exist? | ||||||||
| #' | ||||||||
| #' Report \code{TRUE} if a turtle exists inside the \code{turtles} agentset, report | ||||||||
| #' \code{FALSE} otherwise. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param who Integer. Vector of the "who" numbers of the turtles to check for existence. | ||||||||
| #' | ||||||||
| #' @param breed Characters. Vector of "breed" names for the turtles to check | ||||||||
| #' for existence. Must be of length 1 or of length \code{n}. | ||||||||
| #' If missing, there is | ||||||||
| #' no distinction based upon "breed". | ||||||||
| #' | ||||||||
| #' @return Logical. Vector of \code{TRUE} or \code{FALSE} if the turtles with | ||||||||
| #' the given \code{who} numbers and potentially given \code{breed} exist or not | ||||||||
| #' in the given \code{turtles} agentset. | ||||||||
| #' | ||||||||
| #' @details If \code{breed} is provided, the turtle with the given \code{who} number | ||||||||
| #' AND given \code{breed} must exists inside \code{turtles} for \code{TRUE} | ||||||||
| #' to be returned. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#member} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10), breed = c(rep("sheep", 5), rep("wolf", 5))) | ||||||||
| #' tExist(turtles = t1, who = 3, breed = "sheep") | ||||||||
| #' tExist(turtles = t1, who = 9, breed = "sheep") | ||||||||
| #' tExist(turtles = t1, who = c(3, 9)) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname tExist | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "tExist", | ||||||||
| function(turtles, who, breed) { | ||||||||
| standardGeneric("tExist") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname tExist | ||||||||
| setMethod( | ||||||||
| "tExist", | ||||||||
| signature = c("SpatialPointsDataFrame", "numeric", "missing"), | ||||||||
| definition = function(turtles, who) { | ||||||||
| tExist <- who %in% turtles@data$who | ||||||||
| return(tExist) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname tExist | ||||||||
| setMethod( | ||||||||
| "tExist", | ||||||||
| signature = c("SpatialPointsDataFrame", "numeric", "character"), | ||||||||
| definition = function(turtles, who, breed) { | ||||||||
| whoExist <- tExist(turtles = turtles, who = who) | ||||||||
| if(length(breed) == 1 & length(who) != 1){ | ||||||||
| breed <- rep(breed, length(who)) | ||||||||
| } | ||||||||
| whoTurtles <- turtles@data[turtles@data$who %in% who,] # select the who turtles | ||||||||
| whoTurtles <- whoTurtles[match(who, whoTurtles$who),] # order them by the order of given who | ||||||||
| breedExist <- whoTurtles$breed == breed | ||||||||
| return(whoExist & breedExist) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Select turtles | ||||||||
| #' | ||||||||
| #' Report the individuals among \code{turtles} based on their \code{who} numbers | ||||||||
| #' and \code{breed}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param breed Characters. Vector of "breed" names to select the \code{turtles}. | ||||||||
| #' Must be of length 1 or of length \code{turtles}. | ||||||||
| #' If missing, there is | ||||||||
| #' no distinction based upon "breed". | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame of the selected turtles sorted in the order of | ||||||||
| #' the \code{who} and \code{breed} provided. | ||||||||
| #' | ||||||||
| #' @details If no turtle matches the given \code{who} numbers, with potentially the given | ||||||||
| #' \code{breed}, inside \code{turtles}, then an empty SpatialPointsDataFrame is returned. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtle} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10)) | ||||||||
| #' t2 <- turtle(t1, who = 2) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname turtle | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "turtle", | ||||||||
| function(turtles, who, breed) { | ||||||||
| standardGeneric("turtle") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname turtle | ||||||||
| setMethod( | ||||||||
| "turtle", | ||||||||
| signature = c("SpatialPointsDataFrame", "numeric", "missing"), | ||||||||
| definition = function(turtles, who) { | ||||||||
| newTurtles <- turtles[turtles$who %in% who, ] | ||||||||
| if(!identical(newTurtles@data$who, who)){ | ||||||||
| # Order the turtles in the order of the given who | ||||||||
| iTurtles <- match(who, newTurtles@data$who) | ||||||||
| iTurtles <- iTurtles[!is.na(iTurtles)] | ||||||||
| newTurtles@coords <- cbind(xcor = newTurtles@coords[iTurtles,1], ycor = newTurtles@coords[iTurtles,2]) | ||||||||
| newTurtles@data <- newTurtles@data[iTurtles,] | ||||||||
| } | ||||||||
| return(newTurtles) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname turtle | ||||||||
| setMethod( | ||||||||
| "turtle", | ||||||||
| signature = c("SpatialPointsDataFrame", "numeric", "character"), | ||||||||
| definition = function(turtles, who, breed) { | ||||||||
| whoTurtles <- turtle(turtles = turtles, who = who) | ||||||||
| if(length(breed) == 1 & length(who) != 1){ | ||||||||
| breed <- rep(breed, length(who)) | ||||||||
| } | ||||||||
| tSelect <- whoTurtles@data | ||||||||
| tSelect <- tSelect[match(who, tSelect$who),] # order them by the order of given who | ||||||||
| whoBreed <- tSelect[tSelect$breed == breed, "who"] | ||||||||
| turtle(turtles = turtles, who = whoBreed) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Turtles on | ||||||||
| #' | ||||||||
| #' Report the individuals among \code{turtles} that are at the same locations as | ||||||||
| #' the \code{agents}' patches. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @inheritParams turtle | ||||||||
| #' | ||||||||
| #' @param simplify Logical. If \code{simplify = TRUE}, all \code{turtles} on the same | ||||||||
| #' location as any \code{agents} are returned; if \code{simplify = FALSE}, | ||||||||
| #' the \code{turtles} are evaluated on each \code{agents} locations | ||||||||
| #' individually. | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame representing any individuals from \code{turtles} of the given | ||||||||
| #' \code{breed}, if speficied, | ||||||||
| #' located at the same locations as any \code{agents}, if \code{simplify = TRUE}, or | ||||||||
| #' | ||||||||
| #' Matrix (ncol = 2) with the first column "whoTurtles" and the second column | ||||||||
| #' "id" showing which \code{turtles} are on the same | ||||||||
| #' locations as which \code{agents} represented by "id", if \code{simplify = FALSE}. | ||||||||
| #' "id" represents and follows the order of the \code{agents}, not the "who" numbers | ||||||||
| #' of the \code{agents} if \code{agents} are turtles. | ||||||||
| #' | ||||||||
| #' @details The \code{agents} must be located inside the | ||||||||
| #' \code{world}'s extent. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles-on} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = runif(count(patches(w1)))) | ||||||||
| #' t1 <- createTurtles(n = 500, coords = randomXYcor(w1, n = 500)) | ||||||||
| #' | ||||||||
| #' library(SpaDES) | ||||||||
| #' clearPlot() | ||||||||
| #' Plot(w1) | ||||||||
| #' Plot(t1, addTo = "w1") | ||||||||
| #' | ||||||||
| #' t2 <- turtlesOn(world = w1, turtles = t1, agents = patch(w1, 2, 2)) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname turtlesOn | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "turtlesOn", | ||||||||
| function(world, turtles, agents, breed, simplify = TRUE) { | ||||||||
| standardGeneric("turtlesOn") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname turtlesOn | ||||||||
| setMethod( | ||||||||
| "turtlesOn", | ||||||||
| signature = c(world = "NLworlds", turtles = "SpatialPointsDataFrame", agents = "matrix", breed = "missing"), | ||||||||
| definition = function(world, turtles, agents, simplify) { | ||||||||
| pTurtles <- patchHere(world = world, turtles = turtles) # patches where the turtles are | ||||||||
| pTurtles <- cbind(pTurtles, who = turtles@data$who) | ||||||||
| if(simplify == TRUE){ | ||||||||
| pOn <- merge(agents, pTurtles) # patches where the turtles are among the agents patches | ||||||||
| if(nrow(pOn) == 0){ | ||||||||
| return(noTurtles()) | ||||||||
| } else { | ||||||||
| turtle(turtles = turtles, who = pOn[,3]) | ||||||||
| } | ||||||||
| } else { | ||||||||
| agents <- cbind(agents, id = 1:nrow(agents)) | ||||||||
| pOn <- merge(agents, pTurtles) # patches where the turtles are among the agents patches | ||||||||
| pOn <- pOn[order(pOn[,"id"]),] | ||||||||
| turtlesID <- cbind(whoTurtles = pOn[,"who"], id = pOn[,"id"]) | ||||||||
| return(turtlesID) | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname turtlesOn | ||||||||
| setMethod( | ||||||||
| "turtlesOn", | ||||||||
| signature = c(world = "NLworlds", turtles = "SpatialPointsDataFrame", agents = "matrix", breed = "character"), | ||||||||
| definition = function(world, turtles, agents, breed, simplify) { | ||||||||
| tBreed <- turtles[turtles$breed %in% breed,] | ||||||||
| turtlesOn(world = world, turtles = tBreed, agents = agents, simplify = simplify) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname turtlesOn | ||||||||
| setMethod( | ||||||||
| "turtlesOn", | ||||||||
| signature = c(world = "NLworlds", turtles = "SpatialPointsDataFrame", agents = "SpatialPointsDataFrame", breed = "missing"), | ||||||||
| definition = function(world, turtles, agents, simplify) { | ||||||||
| turtlesOn(world = world, turtles = turtles, agents = patchHere(world = world, turtles = agents), simplify = simplify) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname turtlesOn | ||||||||
| setMethod( | ||||||||
| "turtlesOn", | ||||||||
| signature = c(world = "NLworlds", turtles = "SpatialPointsDataFrame", agents = "SpatialPointsDataFrame", breed = "character"), | ||||||||
| definition = function(world, turtles, agents, breed, simplify) { | ||||||||
| turtlesOn(world = world, turtles = turtles, agents = patchHere(world = world, turtles = agents), breed = breed, simplify = simplify) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' No turtles | ||||||||
| #' | ||||||||
| #' Report an empty turtle agentset. | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame with the turtle variables defined | ||||||||
| #' as when using \code{createTurtles()} or \code{createOTurtles()} but | ||||||||
| #' of length equals to 0. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#no-turtles} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' t1 <- noTurtles() | ||||||||
| #' count(t1) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname noTurtles | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "noTurtles", | ||||||||
| function(x) { | ||||||||
| standardGeneric("noTurtles") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname noTurtles | ||||||||
| setMethod( | ||||||||
| "noTurtles", | ||||||||
| signature = "missing", | ||||||||
| definition = function() { | ||||||||
| t0 <- createTurtles(n = 1, coords = cbind(xcor = 0, ycor = 0)) | ||||||||
| return(t0[t0$who == 1,]) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Turtles at | ||||||||
| #' | ||||||||
| #' Report the indviduals among \code{turtles} that are located on the patches at | ||||||||
| #' \code{(dx, dy)} distances of the | ||||||||
| #' \code{agents}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @inheritParams turtle | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame representing the individuals among \code{turtles} | ||||||||
| #' of the given \code{breed}, if specified, | ||||||||
| #' which are located on the patches at \code{(dx, dy)} distances of the | ||||||||
| #' \code{agents}. | ||||||||
| #' | ||||||||
| #' @details If the patch at distance \code{(dx, dy)} | ||||||||
| #' of an agent is outside of the \code{world}'s extent and \code{torus = FALSE}, no turtle is returned; | ||||||||
| #' if \code{torus = TRUE}, the turtle located on the patch whose coordinates | ||||||||
| #' are defined from the wrapped \code{world} is returned. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles-at} | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#at-points} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' t1 <- createTurtles(n = 10, coords = cbind(xcor = 0:9, ycor = 0:9), breed = c(rep("sheep", 5), rep("wolf", 5))) | ||||||||
| #' t2 <- turtlesAt(world = w1, turtles = t1, agents = turtle(t1, who = 0), dx = 1, dy = 1) | ||||||||
| #' t3 <- turtlesAt(world = w1, turtles = t1, agents = patch(w1, c(3,4,5), c(3,4,5)), dx = 1, dy = 1, breed = "sheep") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname turtlesAt | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "turtlesAt", | ||||||||
| function(world, turtles, agents, dx, dy, breed, torus = FALSE) { | ||||||||
| standardGeneric("turtlesAt") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname turtlesAt | ||||||||
| setMethod( | ||||||||
| "turtlesAt", | ||||||||
| signature = c("NLworlds", "SpatialPointsDataFrame", "matrix", "numeric", "numeric", "missing", "ANY"), | ||||||||
| definition = function(world, turtles, agents, dx, dy, torus) { | ||||||||
| pAt <- patchAt(world = world, agents = agents, dx = dx, dy = dy) | ||||||||
| turtlesOn(world = world, turtles = turtles, agents = pAt) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname turtlesAt | ||||||||
| setMethod( | ||||||||
| "turtlesAt", | ||||||||
| signature = c("NLworlds", "SpatialPointsDataFrame", "SpatialPointsDataFrame", "numeric", "numeric", "missing", "ANY"), | ||||||||
| definition = function(world, turtles, agents, dx, dy, torus) { | ||||||||
| pAt <- patchAt(world = world, agents = agents, dx = dx, dy = dy) | ||||||||
| turtlesOn(world = world, turtles = turtles, agents = pAt) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname turtlesAt | ||||||||
| setMethod( | ||||||||
| "turtlesAt", | ||||||||
| signature = c("NLworlds", "SpatialPointsDataFrame", "matrix", "numeric", "numeric", "character", "ANY"), | ||||||||
| definition = function(world, turtles, agents, dx, dy, breed, torus) { | ||||||||
| pAt <- patchAt(world = world, agents = agents, dx = dx, dy = dy) | ||||||||
| turtlesOn(world = world, turtles = turtles, agents = pAt, breed = breed) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname turtlesAt | ||||||||
| setMethod( | ||||||||
| "turtlesAt", | ||||||||
| signature = c("NLworlds", "SpatialPointsDataFrame", "SpatialPointsDataFrame", "numeric", "numeric", "character", "ANY"), | ||||||||
| definition = function(world, turtles, agents, dx, dy, breed, torus) { | ||||||||
| pAt <- patchAt(world = world, agents = agents, dx = dx, dy = dy) | ||||||||
| turtlesOn(world = world, turtles = turtles, agents = pAt, breed = breed) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Create a turtle agenset | ||||||||
| #' | ||||||||
| #' Report a turtle agentset containing all turtles provided in the inputs. | ||||||||
| #' | ||||||||
| #' @param ... SpatialPointsDataFrame objects created by \code{createTurtles()} or | ||||||||
| #' by \code{createOTurtles()} representing the moving agents. | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame with all the turtles provided in the inputs. | ||||||||
| #' | ||||||||
| #' @details Duplicated turtles are removed. Duplicates are identified based on the | ||||||||
| #' turtles' coordinates and all their variables values. | ||||||||
| #' | ||||||||
| #' This functions does not affect the turtles coordinates and variables. | ||||||||
| #' Therefore there may be multiple turtles with the same variable value (e.g., | ||||||||
| #' "who" number, and color). This must be taken care of prior or later | ||||||||
| #' using this function to avoid further confusions. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtle-set} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10), breed = "sheep") | ||||||||
| #' t2 <- createTurtles(n = 2, coords = randomXYcor(w1, n = 2), breed = "wolf") | ||||||||
| #' t3 <- createTurtles(n = 1, coords = randomXYcor(w1, n = 1), breed = "sheperd") | ||||||||
| #' t4 <- turtleSet(t1, t2, t3) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @importFrom data.table rbindlist | ||||||||
| #' @docType methods | ||||||||
| #' @rdname turtleSet | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "turtleSet", | ||||||||
| function(...) { | ||||||||
| standardGeneric("turtleSet") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname turtleSet | ||||||||
| setMethod( | ||||||||
| "turtleSet", | ||||||||
| signature = "SpatialPointsDataFrame", | ||||||||
| definition = function(...) { | ||||||||
| dots <-list(...) | ||||||||
| allList <- lapply(dots, function(x){cbind(x@coords, x@data)}) | ||||||||
| allDf <- rbindlist(allList) | ||||||||
| allDf <- as.data.frame(unique(allDf)) | ||||||||
| allTurtles <- SpatialPointsDataFrame(coords = cbind(xcor = allDf[,1], ycor = allDf[,2]), data = allDf[,3:ncol(allDf)]) | ||||||||
| return(allTurtles) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' New turtles variable | ||||||||
| #' | ||||||||
| #' Create a new variable for the turtles. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param tVar Character. the name of the \code{turtles} variable to create. | ||||||||
| #' | ||||||||
| #' @param tVal Vector representing the values of \code{tVar}. | ||||||||
| #' Must be of length 1 or of length \code{turtles}. | ||||||||
| #' If missing, \code{NA} is given. | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame representing the \code{turtles} with the new | ||||||||
| #' variable \code{tVar} added. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles-own} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' t1 <- createTurtles(n = 5, coords = cbind(xcor = 0, ycor = 0)) | ||||||||
| #' t1 <- turtlesOwn(turtles = t1, tVar = "sex", tVal = c("F", "F", "F", "M", "M")) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname turtlesOwn | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "turtlesOwn", | ||||||||
| function(turtles, tVar, tVal) { | ||||||||
| standardGeneric("turtlesOwn") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname turtlesOwn | ||||||||
| setMethod( | ||||||||
| "turtlesOwn", | ||||||||
| signature = c("SpatialPointsDataFrame", "character", "missing"), | ||||||||
| definition = function(turtles, tVar) { | ||||||||
| newData <- cbind(turtles@data, rep(NA, length(turtles))) | ||||||||
| colnames(newData)[ncol(turtles@data) + 1] <- tVar | ||||||||
| turtles@data <- newData | ||||||||
| return(turtles) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname turtlesOwn | ||||||||
| setMethod( | ||||||||
| "turtlesOwn", | ||||||||
| signature = c("SpatialPointsDataFrame", "character", "ANY"), | ||||||||
| definition = function(turtles, tVar, tVal) { | ||||||||
| newTurtles <- turtlesOwn(turtles = turtles, tVar = tVar) | ||||||||
| turtles@data[,tVar] <- tVal | ||||||||
| return(turtles) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Substract headings | ||||||||
| #' | ||||||||
| #' Compute the difference between headings. | ||||||||
| #' | ||||||||
| #' @param angle1 SpatialPointsDataFrame created by \code{createTurtles()} or | ||||||||
| #' by \code{createOTurtles()} representing the moving agents, or | ||||||||
| #' | ||||||||
| #' Numeric. Vector of angles. | ||||||||
| #' | ||||||||
| #' @param angle2 SpatialPointsDataFrame created by \code{createTurtles()} or | ||||||||
| #' by \code{createOTurtles()} representing the moving agents, or | ||||||||
| #' | ||||||||
| #' Numeric. Vector of angles. | ||||||||
| #' | ||||||||
| #' @param range360 Logical. If \code{range360 = TRUE}, returned values are between 0° and | ||||||||
| #' 360°; if \code{range360 = FALSE}, returned values are between -180° and 180°. | ||||||||
| #' Default is \code{range360 = FALSE}. | ||||||||
| #' | ||||||||
| #' @return Numeric. Vector of the smallest angles in degrees | ||||||||
| #' by which \code{angle1} could be rotated to produce \code{angle2} | ||||||||
| #' (i.e., the target heading). | ||||||||
| #' | ||||||||
| #' @details This function does the opposite as the one in NetLogo where | ||||||||
| #' \code{angle1} is the target heading. | ||||||||
| #' | ||||||||
| #' \code{angle1} and \code{angle2} must be of the same length or if different, | ||||||||
| #' one of them must be of length 1. | ||||||||
| #' | ||||||||
| #' Positive values mean clockwise rotations, negative value mean counterclockwise rotations. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#subtract-headings} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' t1 <- createOTurtles(n = 10, world = w1) | ||||||||
| #' subHeadings(angle1 = t1, angle2 = 0) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @importFrom CircStats rad | ||||||||
| #' @importFrom CircStats deg | ||||||||
| #' @docType methods | ||||||||
| #' @rdname subHeadings | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "subHeadings", | ||||||||
| function(angle1, angle2, range360 = FALSE) { | ||||||||
| standardGeneric("subHeadings") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname subHeadings | ||||||||
| setMethod( | ||||||||
| "subHeadings", | ||||||||
| signature = c(angle1 = "numeric", angle2 = "numeric"), | ||||||||
| definition = function(angle1, angle2, range360) { | ||||||||
| if(length(angle2) != length(angle1)){ | ||||||||
| if(length(angle2) == 1){ | ||||||||
| angle2 <- rep(angle2, length(angle1)) | ||||||||
| } else if(length(angle1) == 1){ | ||||||||
| angle1 <- rep(angle1, length(angle2)) | ||||||||
| } else { | ||||||||
| stop("angle1 and angle2 must be of the same length or one must be of length 1") | ||||||||
| } | ||||||||
| } | ||||||||
| angles <- deg(atan2(sin(rad(angle2) - rad(angle1)), cos(rad(angle2) - rad(angle1)))) | ||||||||
| if(range360 == TRUE){ | ||||||||
| angles[angles < 0] <- angles[angles < 0] + 360 | ||||||||
| } | ||||||||
| return(angles) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname subHeadings | ||||||||
| setMethod( | ||||||||
| "subHeadings", | ||||||||
| signature = c(angle1 = "SpatialPointsDataFrame", angle2 = "numeric"), | ||||||||
| definition = function(angle1, angle2, range360) { | ||||||||
| subHeadings(angle1 = angle1@data$heading, angle2 = angle2, range360 = range360) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname subHeadings | ||||||||
| setMethod( | ||||||||
| "subHeadings", | ||||||||
| signature = c(angle1 = "numeric", angle2 = "SpatialPointsDataFrame"), | ||||||||
| definition = function(angle1, angle2, range360) { | ||||||||
| subHeadings(angle1 = angle1, angle2 = angle2@data$heading, range360 = range360) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname subHeadings | ||||||||
| setMethod( | ||||||||
| "subHeadings", | ||||||||
| signature = c(angle1 = "SpatialPointsDataFrame", angle2 = "SpatialPointsDataFrame"), | ||||||||
| definition = function(angle1, angle2, range360) { | ||||||||
| subHeadings(angle1 = angle1@data$heading, angle2 = angle2@data$heading, range360 = range360) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Others | ||||||||
| #' | ||||||||
| #' Report an agentset of all \code{agents} except specific ones. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param except Matrix (ncol = 2) with the first column "pxcor" and the second | ||||||||
| #' column "pycor" representing the patches coordinates, or | ||||||||
| #' | ||||||||
| #' SpatialPointsDataFrame created by \code{createTurtles()} or | ||||||||
| #' by \code{createOTurtles()} representing the moving agents. | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2) with the first column "pxcor" and the second | ||||||||
| #' column "pycor" representing the patches in \code{agents} without | ||||||||
| #' the ones in \code{except}, or | ||||||||
| #' | ||||||||
| #' SpatialPointsDataFrame representing the turtles in \code{agents} without | ||||||||
| #' the ones in \code{except}. | ||||||||
| #' | ||||||||
| #' @details Both \code{agents} and \code{except} must be of the same class (e.g., both | ||||||||
| #' patches or both turtles). | ||||||||
| #' | ||||||||
| #' Carefull: this function removes turtles only based on similar "who" numbers | ||||||||
| #' and "breed" names. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#other} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # Patches | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) # 100 patches | ||||||||
| #' p1 <- other(agents = patches(w1), except = patch(w1, 0, 0)) | ||||||||
| #' count(p1) # 99 patches | ||||||||
| #' | ||||||||
| #' # Turtles | ||||||||
| #' t1 <- createTurtles(n = 10, coords = cbind(xcor = 0, ycor = 0)) # 10 turtles | ||||||||
| #' t2 <- other(agents = t1, except = turtle(t1, who = 0)) | ||||||||
| #' count(t2) # 9 turtles | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname other | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "other", | ||||||||
| function(agents, except) { | ||||||||
| standardGeneric("other") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname other | ||||||||
| setMethod( | ||||||||
| "other", | ||||||||
| signature = c("matrix", "matrix"), | ||||||||
| definition = function(agents, except) { | ||||||||
| pCoords <- agents[!duplicated(rbind(except, agents))[-(1:nrow(except))],] | ||||||||
| return(pCoords) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname other | ||||||||
| setMethod( | ||||||||
| "other", | ||||||||
| signature = c("SpatialPointsDataFrame", "SpatialPointsDataFrame"), | ||||||||
| definition = function(agents, except) { | ||||||||
| t1Data <- agents@data[,c("who", "breed")] | ||||||||
| t2Data <- except@data[,c("who", "breed")] | ||||||||
| sameTurtles <- merge(t1Data, t2Data) | ||||||||
| if(nrow(sameTurtles) == 0){ | ||||||||
| # If agents does not contain except | ||||||||
| return(agents) | ||||||||
| } else { | ||||||||
| tRemove <- match(sameTurtles$who, t1Data$who) | ||||||||
| newCoords <- agents@coords[-tRemove,] | ||||||||
| newData <- agents@data[-tRemove,] | ||||||||
| if(nrow(newCoords) == 0){ | ||||||||
| # If agents and except are the same | ||||||||
| noTurtles() | ||||||||
| } else { | ||||||||
| newTurtles <- SpatialPointsDataFrame(coords = newCoords, data = newData) | ||||||||
| return(newTurtles) | ||||||||
| } | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Layout turtles on a circle | ||||||||
| #' | ||||||||
| #' Relocate the \code{turtles} on a circle centered on the \code{world}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param radius Numeric. Radius of the circle. | ||||||||
| #' | ||||||||
| #' @return SpatialPointsDataFrame representing the \code{turtles} with updated | ||||||||
| #' coordinates and updated data for their "heading" values and | ||||||||
| #' previous coordinates "prevX" | ||||||||
| #' and "prevY". | ||||||||
| #' | ||||||||
| #' @details The \code{turtles} point outwards. | ||||||||
| #' | ||||||||
| #' If the | ||||||||
| #' \code{radius} value leads turtles outside of the \code{world}'s extent | ||||||||
| #' and \code{torus = TRUE}, they are | ||||||||
| #' relocated on the other sides of the \code{world}, inside its extent; if | ||||||||
| #' \code{torus = FALSE}, the turtles are located past | ||||||||
| #' the world's extent. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#layout-circle} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = runif(count(patches(w1)))) | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10)) | ||||||||
| #' | ||||||||
| #' library(SpaDES) | ||||||||
| #' clearPlot() | ||||||||
| #' Plot(w1) | ||||||||
| #' Plot(t1, addTo = "w1") | ||||||||
| #' | ||||||||
| #' t2 <- layoutCircle(world = w1, turtles = t1, radius = 3) | ||||||||
| #' Plot(t2, addTo = "w1") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname layoutCircle | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "layoutCircle", | ||||||||
| function(world, turtles, radius, torus = FALSE) { | ||||||||
| standardGeneric("layoutCircle") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname layoutCircle | ||||||||
| setMethod( | ||||||||
| "layoutCircle", | ||||||||
| signature = c(world = "NLworld", turtles = "SpatialPointsDataFrame", radius = "numeric"), | ||||||||
| definition = function(world, turtles, radius, torus) { | ||||||||
| tSurrogates <- createOTurtles(n = length(turtles), world = world) | ||||||||
| turtles@coords <- tSurrogates@coords | ||||||||
| turtles@data$heading <- tSurrogates@data$heading | ||||||||
| fd(world = world, turtles = turtles, dist = radius, torus = torus, out = TRUE) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Values of an agents variable | ||||||||
| #' | ||||||||
| #' Report the \code{agents} values for the requested variable. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param var Character. Vector of the name of the selected \code{agents} variables. | ||||||||
| #' If \code{agents} are patches and the \code{world} is a | ||||||||
| #' \code{NLworld} object, \code{var} must not be provided. If | ||||||||
| #' \code{agents} are patches and the \code{world} is a \code{NLworldStack} | ||||||||
| #' object, \code{var} is the name of the layers to use to define the patches | ||||||||
| #' values. If \code{agents} are turtles, \code{var} is some of | ||||||||
| #' the turtles' variable and can be equal to \code{"xcor"}, | ||||||||
| #' \code{"ycor"}, any of the variables created when turtles were created, | ||||||||
| #' as well as any variable created using \code{turtlesOwn()}. | ||||||||
| #' | ||||||||
| #' @return Vector of values for the \code{agents} if one variable is requested. The class depends | ||||||||
| #' of the variable class. The order of the vector follows the order | ||||||||
| #' of the \code{agents}, or | ||||||||
| #' | ||||||||
| #' Matrix or Dataframe (ncol = \code{length(var)}, nrow = \code{count(agents)}) | ||||||||
| #' if \code{agents} are patches or turtles, of the | ||||||||
| #' values for the requested variables for the \code{agents}. The row order | ||||||||
| #' of the returned matrix follws the order of the \code{agents}. | ||||||||
| #' | ||||||||
| #' @details If \code{agents} are patches, \code{world} must be provided. | ||||||||
| #' If \code{agents} are turtles, \code{world} must not be provided. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#of} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = 1:25) | ||||||||
| #' of(world = w1, agents = patch(w1, c(0,0), c(4,0))) | ||||||||
| #' | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10)) | ||||||||
| #' of(agents = t1, var = "heading") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname of | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "of", | ||||||||
| function(world, agents, var) { | ||||||||
| standardGeneric("of") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname of | ||||||||
| setMethod( | ||||||||
| "of", | ||||||||
| signature = c("missing", "SpatialPointsDataFrame", "character"), | ||||||||
| definition = function(agents, var) { | ||||||||
| if(length(var) == 1){ | ||||||||
| if(var == "xcor"){ | ||||||||
| return(agents@coords[,1]) | ||||||||
| } else if(var == "ycor"){ | ||||||||
| return(agents@coords[,2]) | ||||||||
| } else { | ||||||||
| return(agents@data[,var]) | ||||||||
| } | ||||||||
| } else { | ||||||||
| if(any(var == "xcor" | var == "ycor")){ | ||||||||
| agentsData <- cbind(agents@coords, agents@data) | ||||||||
| return(agentsData[,var]) | ||||||||
| } else { | ||||||||
| agents@data[,var] | ||||||||
| } | ||||||||
| } | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname of | ||||||||
| setMethod( | ||||||||
| "of", | ||||||||
| signature = c("NLworld", "matrix", "missing"), | ||||||||
| definition = function(world, agents) { | ||||||||
| valuesW <- values(world) | ||||||||
| if(identical(patches(world), agents)){ | ||||||||
| return(valuesW) | ||||||||
| } else { | ||||||||
| cells <- cellFromPxcorPycor(world = world, pxcor = agents[,1], pycor = agents[,2]) | ||||||||
| return(valuesW[cells]) | ||||||||
| } | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname of | ||||||||
| setMethod( | ||||||||
| "of", | ||||||||
| signature = c("NLworldStack", "matrix", "character"), | ||||||||
| definition = function(world, agents, var) { | ||||||||
| valuesW <- values(world) | ||||||||
| if(identical(patches(world), agents)){ | ||||||||
| return(valuesW[,var]) | ||||||||
| } else { | ||||||||
| cells <- cellFromPxcorPycor(world = world, pxcor = agents[,1], pycor = agents[,2]) | ||||||||
| if(length(cells) != 1 | length(var) == 1){ | ||||||||
| return(valuesW[cells, var]) | ||||||||
| } else { | ||||||||
| cellVal <- valuesW[cells, var] | ||||||||
| cellVatMat <- matrix(cellVal, ncol = length(var), dimnames = list(NULL, var)) | ||||||||
| return(cellVatMat) | ||||||||
| } | ||||||||
| } | ||||||||
| }) | ||||||||
| /examples/Wolf-Sheep-Predation/Wolf-Sheep-Predation.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| ################################################################################ | ||||||||
| # Wolf sheep predation | ||||||||
| # by Wilensky (1997) NetLogo Wolf Sheep Predation model. | ||||||||
| # http://ccl.northwestern.edu/netlogo/models/WolfSheepPredation | ||||||||
| # | ||||||||
| # Converted into R using the NetLogoR package | ||||||||
| # by Sarah Bauduin | ||||||||
| # | ||||||||
| # | ||||||||
| ## Packages required | ||||||||
| library(NetLogoR) | ||||||||
| library(SpaDES) | ||||||||
| library(profvis) | ||||||||
| ## Global variables (some represent the model buttons) | ||||||||
| # Grass settings | ||||||||
| grassOn <- TRUE # TRUE to include grass in the model, FALSE to only include wolves and sheep | ||||||||
| grassTGrowth <- 30 # how long it takes for grass to regrow once it is eaten | ||||||||
| numGreen <- numeric() # keep track of how much grass there is | ||||||||
| # Sheep settings | ||||||||
| nSheep <- 100 # initial sheep population size | ||||||||
| gainFoodSheep <- 4 # amount of energy sheep get for every grass patch eaten | ||||||||
| reproSheep <- 4 # probability in % of a sheep reproducing at each time step | ||||||||
| numSheep <- nSheep # keep track of how many sheep there are | ||||||||
| # Wolf settings | ||||||||
| nWolf <- 50 # initial wolf population size | ||||||||
| gainFoodWolf <- 20 # amount of energy wolves get for every sheep eaten | ||||||||
| reproWolf <- 5 # probability in % of a wolf reproducing at each time step | ||||||||
| numWolves <- nWolf # keep track of how many wolves there is | ||||||||
| # torus = TRUE # just for reminder, to be used in the movement functions (e.g., fd()) | ||||||||
| ## Setup | ||||||||
| # Create the world | ||||||||
| grass <- createNLworld(minPxcor = -25, maxPxcor = 25, minPycor = -25, maxPycor = 25) | ||||||||
| # If grassOn is TRUE, assign grass and countdown values to patches | ||||||||
| # Because there are multiple patches variables, a NLworldStack is needed | ||||||||
| # If grassOn is TRUE, the grass grows and the sheep eat it, if FALSE, the sheep don't need to eat | ||||||||
| if(grassOn == TRUE){ | ||||||||
| # Initialize patch values (grass and countdown) at random | ||||||||
| grassVal <- sample(c(0,1), size = length(grass), replace = TRUE) # 0 or 1 (i.e., green or brown in the NetLogo model) | ||||||||
| grass <- set(world = grass, agents = patches(grass), val = grassVal) | ||||||||
| countdown <- grass # countdown is a new NLworld with the same extent as grass | ||||||||
| countdownVal <- runif(n = length(grass), min = 0, max = grassTGrowth) # grass grow clock | ||||||||
| countdown <- set(world = countdown, agents = patches(countdown), val = countdownVal) | ||||||||
| field <- NLstack(grass, countdown) | ||||||||
| } | ||||||||
| # When no patches values are used, using grass, countdown or field as the world argument required by a function does not change anything | ||||||||
| # because they all have the same extent and number of patches | ||||||||
| # When patches values are used (e.g., when the sheep eat the grass), use only field as the world argument for the functions | ||||||||
| # which update and retrieve the patches values | ||||||||
| # When field is updated, the values on the individual NLworld grass and countdown are not updated, only the layers in field are | ||||||||
| # Create the sheep | ||||||||
| sheep <- createTurtles(n = nSheep, coords = randomXYcor(world = grass, n = nSheep), breed = "aSheep", color = rep("red", nSheep)) | ||||||||
| # Add the energy variable | ||||||||
| sheep <- turtlesOwn(turtles = sheep, tVar = "energy", tVal = runif(n = nSheep, min = 0, max = 2 * gainFoodSheep)) | ||||||||
| # Create the wolves | ||||||||
| wolves <- createTurtles(n = nWolf, coords = randomXYcor(world = grass, n = nWolf), breed = "wolf", color = rep("black", nWolf)) | ||||||||
| # Add the energy variable | ||||||||
| wolves <- turtlesOwn(turtles = wolves, tVar = "energy", tVal = runif(n = nWolf, min = 0, max = 2 * gainFoodWolf)) | ||||||||
| # Initialize the count of grass | ||||||||
| if(grassOn == TRUE){ | ||||||||
| pGreen <- NLwith(world = field, var = "grass", agents = patches(field), val = 1) # patches equal to 1 (green) | ||||||||
| numGreen <- count(pGreen) | ||||||||
| } | ||||||||
| # # Visualize the world | ||||||||
| # dev() # open a new plotting window | ||||||||
| # clearPlot() | ||||||||
| # if(grassOn == TRUE){ | ||||||||
| # Plot(field[[1]]) | ||||||||
| # Plot(sheep, addTo = "field$grass") | ||||||||
| # Plot(wolves, addTo = "field$grass") | ||||||||
| # } else { | ||||||||
| # grass <- set(world = grass, agents = patches(grass), val = 0) # cannot plot an empty world | ||||||||
| # Plot(grass) | ||||||||
| # Plot(sheep, addTo = "grass") | ||||||||
| # Plot(wolves, addTo = "grass") | ||||||||
| # } | ||||||||
| ## Functions used in the go procedure | ||||||||
| # Always return the object updated by the function | ||||||||
| # When only one type of input is permitted (e.g., only sheep or only wolves), the function does not need to express arguments | ||||||||
| # When a function can be used by both sheep and wolves, the argument "turtles" must be used when building the function | ||||||||
| # and be replaced by either sheep or wolves when calling the function | ||||||||
| move <- function(turtles){ # sheep and wolves | ||||||||
| # turtles <- right(turtles, angle = runif(n = count(turtles), min = 0, max = 50)) | ||||||||
| # turtles <- left(turtles, angle = runif(n = count(turtles), min = 0, max = 50)) | ||||||||
| # The two above functions can be replaced by this next one, as a negative value to turn right will turn left | ||||||||
| turtles <- right(turtles, angle = runif(n = count(turtles), min = -50, max = 50)) | ||||||||
| turtles <- fd(world = grass, turtles = turtles, dist = 1, torus = TRUE) | ||||||||
| return(turtles) | ||||||||
| } | ||||||||
| # # Test move() | ||||||||
| # plot(wolves, col = rainbow(count(wolves)), pch = 16) | ||||||||
| # for(i in 1:15){ | ||||||||
| # wolves <- move(wolves) | ||||||||
| # points(wolves, col = rainbow(count(wolves)), pch = 16) | ||||||||
| # } | ||||||||
| # # | ||||||||
| eatGrass <- function(){ # only sheep | ||||||||
| pGreen <- NLwith(world = field, var = "grass", agents = patches(field), val = 1) # patches with grass equal to 1 (green) | ||||||||
| sheepOnGreen <- turtlesOn(world = field, turtles = sheep, agents = pGreen) # sheep on green patches | ||||||||
| if(count(sheepOnGreen) != 0){ | ||||||||
| # These sheep gain energy by eating | ||||||||
| energySheep <- of(agents = sheepOnGreen, var = "energy") # energy before eating | ||||||||
| sheep <- set(turtles = sheep, agents = sheepOnGreen, var = "energy", val = energySheep + gainFoodSheep) # update energy | ||||||||
| # If a sheep is on a green patch (value equal to 1), it eats the grass and turns it to brown (value to 0) | ||||||||
| pHere <- patchHere(world = field, turtles = sheepOnGreen) | ||||||||
| field <- set(world = field, agents = pHere, var = "grass", val = 0) | ||||||||
| } | ||||||||
| return(list(field, sheep)) # return the two objects updated in this function | ||||||||
| } | ||||||||
| # # Test eatGrass() | ||||||||
| # grass <- createNLworld(1, 10, 1, 10) | ||||||||
| # grass <- set(world = grass, agents = patches(grass), val = c(rep(1, 50), rep(0, 50))) | ||||||||
| # countdown <- grass | ||||||||
| # countdown <- set(world = countdown, agents = patches(countdown), val = 0) | ||||||||
| # field <- NLstack(grass, countdown) | ||||||||
| # sheep <- createTurtles(n = 10, coords = cbind(xcor = 1:10, ycor = 1:10)) | ||||||||
| # sheep <- turtlesOwn(turtles = sheep, tVar = "energy", tVal = 1:10) | ||||||||
| # plot(field$grass) | ||||||||
| # points(sheep) | ||||||||
| # resultsEatGrass <- eatGrass() | ||||||||
| # fieldEat <- resultsEatGrass[[1]] | ||||||||
| # plot(fieldEat$grass) | ||||||||
| # sheepEat <- resultsEatGrass[[2]] | ||||||||
| # of(agents = sheepEat, var = "energy")[6:10] == (6:10 + gainFoodSheep) | ||||||||
| # # | ||||||||
| death <- function(turtles){ # sheep and wolves | ||||||||
| # When energy dips below 0, die | ||||||||
| whoEnergy <- of(agents = turtles, var = c("who", "energy")) | ||||||||
| who0 <- whoEnergy[which(whoEnergy$energy < 0), "who"] # "who" numbers of the turtles with their energy value below 0 | ||||||||
| if(length(who0) != 0){ | ||||||||
| turtles <- die(turtles = turtles, who = who0) | ||||||||
| } | ||||||||
| return(turtles) | ||||||||
| } | ||||||||
| # # Test death() | ||||||||
| # count1 <- count(wolves) | ||||||||
| # count2 <- count(wolves) | ||||||||
| # for(i in 1:100){ | ||||||||
| # energy <- runif(count(wolves), min = -10, max = 100) | ||||||||
| # wolves <- set(turtles = wolves, agents = wolves, var = "energy", val = energy) | ||||||||
| # count1 <- c(count1, count(wolves) - length(energy[energy < 0])) | ||||||||
| # wolves <- death(wolves) | ||||||||
| # count2 <- c(count2, count(wolves)) | ||||||||
| # } | ||||||||
| # plot(1:length(count1), count1, pch = 16) | ||||||||
| # points(1:length(count2), count2, pch = 16, col = "red") | ||||||||
| # # | ||||||||
| reproduce <- function(turtles, reproTurtles){ # sheep and wolves | ||||||||
| # Throw dice to see if the turtles will reproduce | ||||||||
| repro <- runif(n = count(turtles), min = 0, max = 100) < reproTurtles | ||||||||
| whoTurtles <- of(agents = turtles, var = "who") # "who" of the turtles before they reproduce | ||||||||
| reproWho <- whoTurtles[repro] # "who" of turtles which reproduce | ||||||||
| reproInd <- turtle(turtles, who = reproWho) # turtles which reproduce | ||||||||
| if(count(reproInd) != 0){ # if there is at least one turtle reproducing | ||||||||
| energyTurtles <- of(agents = reproInd, var = "energy") | ||||||||
| # Divide the energy between the parent and offspring | ||||||||
| turtles <- set(turtles = turtles, agents = reproInd, var = "energy", val = energyTurtles / 2) | ||||||||
| turtles <- hatch(turtles = turtles, who = reproWho, n = 1) # hatch one offspring per parent | ||||||||
| # Move the offspring by 1 step | ||||||||
| whoNewTurtles <- of(agents = turtles, var = "who") # "who" of the turtles after they reproduced | ||||||||
| whoOffspring <- which(!whoNewTurtles %in% whoTurtles) # "who" of offspring | ||||||||
| offspring <- turtle(turtles = turtles, who = whoOffspring) | ||||||||
| offspringMoved <- right(turtles = offspring, angle = runif(n = count(offspring), min = 0, max = 360)) | ||||||||
| offspringMoved <- fd(world = grass, turtles = offspring, dist = 1, torus = TRUE) | ||||||||
| # Update the headings and coordinates of the offsprings inside the turtles | ||||||||
| valOffspring <- of(agents = offspringMoved, var = c("heading", "xcor", "ycor")) | ||||||||
| turtles <- set(turtles = turtles, agents = offspring, var = c("heading", "xcor", "ycor"), val = valOffspring) | ||||||||
| } | ||||||||
| return(turtles) | ||||||||
| } | ||||||||
| # # Test reproduce() | ||||||||
| # count1 <- count(wolves) | ||||||||
| # count2 <- count(wolves) | ||||||||
| # for(i in 1:100){ | ||||||||
| # count1<-c(count1,count(wolves) + count(wolves) * reproWolf / 100) | ||||||||
| # wolves <- reproduce(wolves, reproWolf) | ||||||||
| # count2<-c(count2, count(wolves)) | ||||||||
| # } | ||||||||
| # plot(1:length(count1), count1, pch = 16) | ||||||||
| # points(1:length(count2), count2, pch = 16, col = "red") | ||||||||
| # # | ||||||||
| catchSheep <- function(){ # only wolves | ||||||||
| # "who" numbers of sheep that are on the same patches as the wolves | ||||||||
| sheepWolves <- turtlesOn(world = grass, turtles = sheep, agents = wolves, simplify = FALSE) | ||||||||
| if(nrow(sheepWolves) != 0){ | ||||||||
| # sheepWolves[,"whoTurtles"] are the "who" numbers of sheep | ||||||||
| # sheepWolves[,"id"] represent the rank/order of the individual wolf in the wolves (! not the "who" numbers of the wolves) | ||||||||
| sheepGrabbed <- oneOf(agents = sheepWolves) # grab one random sheep | ||||||||
| sheep <- die(turtles = sheep, who = sheepGrabbed) # kill the grabbed sheep | ||||||||
| whoWolves <- of(agents = wolves, var = "who") | ||||||||
| whoGrabbingWolves <- whoWolves[unique(sheepWolves[,"id"])] | ||||||||
| grabbingWolves <- turtle(turtles = wolves, who = whoGrabbingWolves) | ||||||||
| energyGrabbingWolves <- of(agents = grabbingWolves, var = "energy") | ||||||||
| # Get energy from eating for the wolves who grabbed sheep | ||||||||
| wolves <- set(turtles = wolves, agents = grabbingWolves, var = "energy", val = energyGrabbingWolves + gainFoodWolf) | ||||||||
| } | ||||||||
| return(list(sheep, wolves))# return the two objects updated in this function | ||||||||
| } | ||||||||
| # # Test catchSheep() | ||||||||
| # grass <- createNLworld(1, 10, 1, 10) | ||||||||
| # grass <- set(world = grass, agents = patches(grass), val = c(rep(1, 50), rep(0, 50))) | ||||||||
| # countdown <- grass | ||||||||
| # countdown <- set(world = countdown, agents = patches(countdown), val = 0) | ||||||||
| # field <- NLstack(grass, countdown) | ||||||||
| # sheep <- createTurtles(n = 10, coords = cbind(xcor = c(1,1,2,2,3,4,5,6,7,8), ycor = c(1,1,2,2,3,4,5,6,7,8))) | ||||||||
| # wolves <- createTurtles(n = 5, coords = cbind(xcor = 1:5, ycor = 1:5)) | ||||||||
| # wolves <- turtlesOwn(turtles = wolves, tVar = "energy", tVal = 1:5) | ||||||||
| # catchSheepResults <- catchSheep() | ||||||||
| # sheepCatch <- catchSheepResults[[1]] | ||||||||
| # wolvesCatch <- catchSheepResults[[2]] | ||||||||
| # count(sheepCatch) == 5 | ||||||||
| # count(wolves) == 5 | ||||||||
| # of(agents = wolvesCatch, var = "energy") == (1:5 + gainFoodWolf) | ||||||||
| # # | ||||||||
| growGrass <- function(){ # only patches | ||||||||
| # Identify patches with grass equal to 0 (brown) and countdown less or equal to 0 | ||||||||
| pBrown <- NLwith(world = field, var = "grass", agents = patches(field), val = 0) | ||||||||
| pBrownCountdown <- of(world = field, var = "countdown", agents = pBrown) # countdown values for the patches equal to 0 (brown) | ||||||||
| pBrownCountdown0 <- which(pBrownCountdown <= 0) # patches with a countdown <= 0 | ||||||||
| if(length(pBrownCountdown0) != 0){ | ||||||||
| pGrow <- pBrown[pBrownCountdown0, ] # patches with grass equal to 0 (brown) and countdown <= 0 | ||||||||
| # Grow some grass on these patches and reset the countdown | ||||||||
| field <- set(world = field, var = c("grass", "countdown"), agents = pGrow, | ||||||||
| val = cbind(grass = rep(1, count(pGrow)), countdown = rep(grassTGrowth, count(pGrow)))) | ||||||||
| } | ||||||||
| pBrownCountdown1 <- which(!pBrownCountdown <= 0) # patches with a countdown > 0 | ||||||||
| if(length(pBrownCountdown1) != 0){ | ||||||||
| pWait <- pBrown[pBrownCountdown1, ] # patches with grass equal to 0 (brown) and countdown > 0 | ||||||||
| # Decrease the countdown for the patches which wait | ||||||||
| field <- set(world = field, var = "countdown", agents = pWait, val = pBrownCountdown[pBrownCountdown1] - 1) | ||||||||
| } | ||||||||
| return(field) | ||||||||
| } | ||||||||
| # # Test growGrass() | ||||||||
| # grass <- createNLworld(1, 5, 1, 5) | ||||||||
| # grass <- set(world = grass, agents = patches(grass), val = c(rep(1, 10), rep(0, 15))) | ||||||||
| # countdown <- grass | ||||||||
| # countdown <- set(world = countdown, agents = patches(countdown), val = c(rep(-1, 15), rep(1, 10))) | ||||||||
| # field <- NLstack(grass, countdown) | ||||||||
| # fieldGrow <- growGrass() | ||||||||
| # of(world = fieldGrow, agents = patches(fieldGrow), var = "grass") == c(rep(1, 15), rep(0, 10)) | ||||||||
| # of(world = fieldGrow, agents = patches(fieldGrow), var = "countdown") == c(rep(-1, 10), rep(grassTGrowth, 5), rep(0, 10)) | ||||||||
| # # | ||||||||
| ## Go | ||||||||
| profvisWolfSheep <- profvis({ | ||||||||
| time <- 0 | ||||||||
| while((NLany(sheep) | NLany(wolves)) & time < 500 ){ # as long as there are sheep or wolves in the world (time steps maximum at 500) | ||||||||
| # Ask sheep | ||||||||
| if(count(sheep) != 0){ | ||||||||
| sheep <- move(sheep) | ||||||||
| if(grassOn == TRUE){ | ||||||||
| energySheep <- of(agents = sheep, var = "energy") | ||||||||
| sheep <- set(turtles = sheep, agents = sheep, var = "energy", val = energySheep - 1) | ||||||||
| eatGrassResults <- eatGrass() # in the results are stored both "field" and "sheep" | ||||||||
| field <- eatGrassResults[[1]] # reassign the object with their updated values | ||||||||
| sheep <- eatGrassResults[[2]] | ||||||||
| } | ||||||||
| sheep <- death(sheep) | ||||||||
| if(count(sheep) != 0){ | ||||||||
| sheep <- reproduce(sheep, reproSheep) | ||||||||
| } | ||||||||
| } | ||||||||
| # Ask wolves | ||||||||
| if(count(wolves) != 0){ | ||||||||
| wolves <- move(wolves) | ||||||||
| energyWolves <- of(agents = wolves, var = "energy") | ||||||||
| wolves <- set(turtles = wolves, agents = wolves, var = "energy", val = energyWolves - 1) | ||||||||
| catchSheepResults <- catchSheep() # in the results are stored both "sheep" and "wolves" | ||||||||
| sheep <- catchSheepResults[[1]] # reassign the object with their updated values | ||||||||
| wolves <- catchSheepResults[[2]] | ||||||||
| wolves <- death(wolves) | ||||||||
| if(count(wolves) != 0){ | ||||||||
| wolves <- reproduce(wolves, reproWolf) | ||||||||
| } | ||||||||
| } | ||||||||
| # Ask grass | ||||||||
| if(grassOn == TRUE){ | ||||||||
| field <- growGrass() | ||||||||
| pGreen <- NLwith(world = field, var = "grass", agents = patches(field), val = 1) # patches equal to 1 (green) | ||||||||
| npGreen <- count(pGreen) | ||||||||
| numGreen <- c(numGreen, npGreen) # add the new number of green patches | ||||||||
| } | ||||||||
| numSheep <- c(numSheep, count(sheep)) # add the new number of sheep | ||||||||
| numWolves <- c(numWolves, count(wolves)) # add the new numbr of wolves | ||||||||
| time <- time + 1 | ||||||||
| # # Help for checking the model is working | ||||||||
| #print(time) | ||||||||
| } | ||||||||
| }) | ||||||||
| ## Plot outputs | ||||||||
| dev() | ||||||||
| timeStep <- 1:length(numSheep) | ||||||||
| if(grassOn == TRUE){ | ||||||||
| plot(timeStep, numSheep, type = "l", col = "blue", lwd = 2, ylab = "Population size", xlab = "Time step", | ||||||||
| ylim = c(min = 0, max = max(c(max(numSheep), max(numWolves), max(numGreen / 4))))) | ||||||||
| lines(timeStep, numWolves, col = "red", lwd = 2) | ||||||||
| lines(timeStep, numGreen / 4, col = "green", lwd = 2) | ||||||||
| legend("topleft", legend = c("Sheep", "Wolves", "Grass / 4"), lwd = c(2, 2, 2), col = c("blue", "red", "green"), | ||||||||
| bg = "white") | ||||||||
| } else { | ||||||||
| plot(timeStep, numSheep, type = "l", col = "blue", lwd = 2, ylab = "Population size", xlab = "Time step", | ||||||||
| ylim = c(min = 0, max = max(c(max(numSheep), max(numWolves))))) | ||||||||
| lines(timeStep, numWolves, col = "red", lwd = 2) | ||||||||
| legend("topleft", legend = c("Sheep", "Wolves"), lwd = c(2, 2), col = c("blue", "red"), bg = "white") | ||||||||
| } | ||||||||
| profvisWolfSheep | ||||||||
| C:\Eliot\GitHub\NetLogoR/R/agentset-functions.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| ################################################################################ | ||||||||
| #' All agents? | ||||||||
| #' | ||||||||
| #' Report \code{TRUE} if all \code{agents} have their variable equal to a given value, | ||||||||
| #' report \code{FALSE} otherwise. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Logical. \code{TRUE} if all the \code{agents} have their variable equal to | ||||||||
| #' \code{val}, \code{FALSE} otherwise. | ||||||||
| #' | ||||||||
| #' @details \code{world} must not be provided if \code{agents} are turtles. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#all} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # Patches | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = runif(count(patches(w1)))) | ||||||||
| #' NLall(agents = patches(w1), world = w1, val = 5) | ||||||||
| #' w2 <- w1 | ||||||||
| #' w2 <- set(world = w1, agents = patches(w1), val = 5) | ||||||||
| #' NLall(agents = patches(w2), world = w2, val = 5) | ||||||||
| #' | ||||||||
| #' # Turtles | ||||||||
| #' t1 <- createTurtles(n = 5, coords = cbind(xcor = 1, ycor = 1), heading = c(1, 2, 2, 1, 2)) | ||||||||
| #' NLall(agents = t1, var = "xcor", val = 1) | ||||||||
| #' NLall(agents = t1, var = "heading", val = 2) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname NLall | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "NLall", | ||||||||
| function(agents, world, var, val) { | ||||||||
| standardGeneric("NLall") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname NLall | ||||||||
| setMethod( | ||||||||
| "NLall", | ||||||||
| signature = c("matrix", "NLworld", "missing", "ANY"), | ||||||||
| definition = function(agents, world, val) { | ||||||||
| withVal <- NLwith(agents = agents, world = world, val = val) | ||||||||
| allTrue <- ifelse(nrow(agents) == nrow(withVal), TRUE, FALSE) | ||||||||
| return(allTrue) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname NLall | ||||||||
| setMethod( | ||||||||
| "NLall", | ||||||||
| signature = c("matrix", "NLworldStack", "character", "ANY"), | ||||||||
| definition = function(agents, world, var, val) { | ||||||||
| names_l <- names(world) | ||||||||
| l <- match(var, names_l) | ||||||||
| world_l <- world[[l]] | ||||||||
| NLall(world = world_l, agents = agents, val = val) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname NLall | ||||||||
| setMethod( | ||||||||
| "NLall", | ||||||||
| signature = c("SpatialPointsDataFrame", "missing", "character", "ANY"), | ||||||||
| definition = function(agents, var, val) { | ||||||||
| withVal <- NLwith(agents = agents, var = var, val = val) | ||||||||
| allTrue <- ifelse(length(agents) == length(withVal), TRUE, FALSE) | ||||||||
| return(allTrue) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Any agents? | ||||||||
| #' | ||||||||
| #' Report \code{TRUE} if \code{agents} is non empty, report \code{FALSE} otherwise. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Logical. \code{TRUE} if there is at least one patch or one turtle in the | ||||||||
| #' \code{agents}, \code{FALSE} otherwise. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#any} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # Patches | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' p1 <- noPatches() | ||||||||
| #' p2 <- patch(w1, 0, 0) | ||||||||
| #' NLany(p1) | ||||||||
| #' NLany(p2) | ||||||||
| #' | ||||||||
| #' # Turtles | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10)) | ||||||||
| #' t2 <- noTurtles() | ||||||||
| #' NLany(t1) | ||||||||
| #' NLany(t2) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname NLany | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "NLany", | ||||||||
| function(agents) { | ||||||||
| standardGeneric("NLany") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname NLany | ||||||||
| setMethod( | ||||||||
| "NLany", | ||||||||
| signature = c("matrix"), | ||||||||
| definition = function(agents) { | ||||||||
| anyAgents <- ifelse(nrow(agents) == 0, FALSE, TRUE) | ||||||||
| if(anyAgents == TRUE){ | ||||||||
| nonNAs <- apply(agents, 2, function(x) length(which(!is.na(x)))) | ||||||||
| if(sum(nonNAs) == 0){ | ||||||||
| anyAgents <- FALSE | ||||||||
| } | ||||||||
| } | ||||||||
| return(anyAgents) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname NLany | ||||||||
| setMethod( | ||||||||
| "NLany", | ||||||||
| signature = c("SpatialPointsDataFrame"), | ||||||||
| definition = function(agents) { | ||||||||
| anyAgents <- ifelse(length(agents) == 0, FALSE, TRUE) | ||||||||
| return(anyAgents) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Count agents | ||||||||
| #' | ||||||||
| #' Report the number of patches or turtles in the \code{agents}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Integer. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#count} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # Patches | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) # 25 patches | ||||||||
| #' p1 <- patches(w1) | ||||||||
| #' count(p1) # 25 | ||||||||
| #' | ||||||||
| #' # Turtles | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10)) | ||||||||
| #' count(t1) # 10 | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname count | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "count", | ||||||||
| function(agents) { | ||||||||
| standardGeneric("count") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname count | ||||||||
| setMethod( | ||||||||
| "count", | ||||||||
| signature = c("matrix"), | ||||||||
| definition = function(agents) { | ||||||||
| return(nrow(agents)) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname count | ||||||||
| setMethod( | ||||||||
| "count", | ||||||||
| signature = c("SpatialPointsDataFrame"), | ||||||||
| definition = function(agents) { | ||||||||
| return(length(agents)) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Sort agents | ||||||||
| #' | ||||||||
| #' Report the \code{agents} sorted according to their value. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2) with the first column "pxcor" and the second column | ||||||||
| #' "pycor" representing the coordinates of the patches, sorted according to | ||||||||
| #' their values, if \code{agents} | ||||||||
| #' are patches, or | ||||||||
| #' | ||||||||
| #' SpatialPointsDataFrame representing the turtles, sorted according | ||||||||
| #' to their \code{var} values, if \code{agents} are | ||||||||
| #' turtles. | ||||||||
| #' | ||||||||
| #' @details \code{world} must not be provided if \code{agents} are turtles. | ||||||||
| #' | ||||||||
| #' The sorting of the \code{agents} is done in a increasing order. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#sort-on} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # Patches | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = sample(1:5, size = count(patches(w1)), replace = TRUE)) | ||||||||
| #' plot(w1) | ||||||||
| #' p1 <- sortOn(agents = patches(w1), world = w1) | ||||||||
| #' | ||||||||
| #' # Turtles | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10)) | ||||||||
| #' sortdHeadingst1 <- sortOn(agents = t1, var = "heading") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname sortOn | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "sortOn", | ||||||||
| function(agents, world, var) { | ||||||||
| standardGeneric("sortOn") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname sortOn | ||||||||
| setMethod( | ||||||||
| "sortOn", | ||||||||
| signature = c("matrix", "NLworld", "missing"), | ||||||||
| definition = function(agents, world) { | ||||||||
| values <- values(world) | ||||||||
| pxcorW <- world@pxcor | ||||||||
| pycorW <- world@pycor | ||||||||
| agentsVal <- values[pxcorW == agents[,1] & pycorW == agents[,2]] | ||||||||
| pCoords <- agents[order(agentsVal),] | ||||||||
| return(pCoords) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname sortOn | ||||||||
| setMethod( | ||||||||
| "sortOn", | ||||||||
| signature = c("matrix", "NLworldStack", "character"), | ||||||||
| definition = function(agents, world, var) { | ||||||||
| names_l <- names(world) | ||||||||
| l <- match(var, names_l) | ||||||||
| world_l <- world[[l]] | ||||||||
| sortOn(world = world_l, agents = agents) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname sortOn | ||||||||
| setMethod( | ||||||||
| "sortOn", | ||||||||
| signature = c("SpatialPointsDataFrame", "missing", "character"), | ||||||||
| definition = function(agents, var) { | ||||||||
| turtles <- cbind(agents@coords, agents@data) | ||||||||
| sortData <- turtles[order(turtles[,var]),] | ||||||||
| agents@coords <- cbind(xcor = sortData[,1], ycor = sortData[,2]) | ||||||||
| agents@data = sortData[,3:ncol(sortData)] | ||||||||
| return(agents) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Agents with | ||||||||
| #' | ||||||||
| #' Report the patches or the turtles among \code{agents} which have their variable | ||||||||
| #' equals to a specific value. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2) with the first column "pxcor" and the second column | ||||||||
| #' "pycor" representing the coordinates of the patches among the \code{agents} | ||||||||
| #' which have their variable | ||||||||
| #' equals to any \code{val}, or | ||||||||
| #' | ||||||||
| #' SpatialPointsDataFrame representing the turtles among the \code{agents} | ||||||||
| #' which have their variable | ||||||||
| #' \code{var} equals to any \code{val}. | ||||||||
| #' | ||||||||
| #' @details \code{world} must not be provided if \code{agents} are turtles. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#with} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # Patches | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = sample(1:5, size = count(patches(w1)), replace = TRUE)) | ||||||||
| #' plot(w1) | ||||||||
| #' p2 <- NLwith(agents = patches(w1), world = w1, val = 2) | ||||||||
| #' | ||||||||
| #' # Turtles | ||||||||
| #' t1 <- createTurtles(n = 5, coords = randomXYcor(w1, n = 5), breed = c("sheep", "sheep", "wolf", "sheep", "sheperd")) | ||||||||
| #' t2 <- NLwith(agents = t1, var = "breed", val = "sheep") | ||||||||
| #' t3 <- NLwith(agents = t1, var = "breed", val = c("sheep", "wolf")) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname NLwith | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "NLwith", | ||||||||
| function(agents, world, var, val) { | ||||||||
| standardGeneric("NLwith") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname NLwith | ||||||||
| setMethod( | ||||||||
| "NLwith", | ||||||||
| signature = c("matrix", "NLworld", "missing", "ANY"), | ||||||||
| definition = function(agents, world, val) { | ||||||||
| pxcor <- agents[,1] | ||||||||
| pycor <- agents[,2] | ||||||||
| values <- world[pxcor,pycor] | ||||||||
| pVal <- which(values %in% val) | ||||||||
| pxcorVal <- pxcor[pVal] | ||||||||
| pycorVal <- pycor[pVal] | ||||||||
| return(cbind(pxcor = pxcorVal, pycor = pycorVal)) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname NLwith | ||||||||
| setMethod( | ||||||||
| "NLwith", | ||||||||
| signature = c("matrix", "NLworldStack", "character", "ANY"), | ||||||||
| definition = function(agents, world, var, val) { | ||||||||
| names_l <- names(world) | ||||||||
| l <- match(var, names_l) | ||||||||
| world_l <- world[[l]] | ||||||||
| NLwith(world = world_l, agents = agents, val = val) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname NLwith | ||||||||
| setMethod( | ||||||||
| "NLwith", | ||||||||
| signature = c("SpatialPointsDataFrame", "missing", "character", "ANY"), | ||||||||
| definition = function(agents, var, val) { | ||||||||
| turtles <- cbind(agents@coords, agents@data) | ||||||||
| turtlesWith <- turtles[turtles[,var] %in% val, ] | ||||||||
| if(nrow(turtlesWith) == 0){ | ||||||||
| noTurtles() | ||||||||
| } else { | ||||||||
| newTurtles <- SpatialPointsDataFrame(coords = cbind(xcor = turtlesWith$xcor, ycor = turtlesWith$ycor), | ||||||||
| data = turtlesWith[,3:ncol(turtlesWith)]) | ||||||||
| return(newTurtles) | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Agents with maximum | ||||||||
| #' | ||||||||
| #' Report the patches or turtles among \code{agents} which have their variable | ||||||||
| #' equals to the maximum value. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2) with the first column "pxcor" and the second column | ||||||||
| #' "pycor" representing the coordinates of the patches among the \code{agents} | ||||||||
| #' which have their variable | ||||||||
| #' equal to the maximum value among the \code{agents}, or | ||||||||
| #' | ||||||||
| #' SpatialPointsDataFrame representing the turtles among the \code{agents} | ||||||||
| #' which have their variable | ||||||||
| #' \code{var} equal to the maximum value among the \code{agents}. | ||||||||
| #' | ||||||||
| #' @details \code{world} must not be provided if \code{agents} are turtles. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#with-max} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # Patches | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = sample(1:5, size = count(patches(w1)), replace = TRUE)) | ||||||||
| #' plot(w1) | ||||||||
| #' p1 <- withMax(agents = patches(w1), world = w1) | ||||||||
| #' | ||||||||
| #' # Turtles | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10), heading = sample(1:3, size = 10, replace= TRUE)) | ||||||||
| #' t2 <- withMax(agents = t1, var = "heading") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname withMax | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "withMax", | ||||||||
| function(agents, world, var) { | ||||||||
| standardGeneric("withMax") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname withMax | ||||||||
| setMethod( | ||||||||
| "withMax", | ||||||||
| signature = c("matrix", "NLworld", "missing"), | ||||||||
| definition = function(agents, world) { | ||||||||
| val <- of(world = world, agents = agents) | ||||||||
| if(length(val[is.na(val)]) == length(val)){ | ||||||||
| stop("patches' values are all NAs") | ||||||||
| } else { | ||||||||
| maxVal <- max(val, na.rm = TRUE) | ||||||||
| NLwith(agents = agents, world = world, val = maxVal) | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname withMax | ||||||||
| setMethod( | ||||||||
| "withMax", | ||||||||
| signature = c("matrix", "NLworldStack", "character"), | ||||||||
| definition = function(agents, world, var) { | ||||||||
| names_l <- names(world) | ||||||||
| l <- match(var, names_l) | ||||||||
| world_l <- world[[l]] | ||||||||
| withMax(world = world_l, agents = agents) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname withMax | ||||||||
| setMethod( | ||||||||
| "withMax", | ||||||||
| signature = c("SpatialPointsDataFrame", "missing", "character"), | ||||||||
| definition = function(agents, var) { | ||||||||
| val_var <- of(agents = agents, var = var) | ||||||||
| if(length(val_var[is.na(val_var)] == length(val_var))){ | ||||||||
| stop("var equals to NA") | ||||||||
| } else { | ||||||||
| maxVal = max(val_var, na.rm = TRUE) | ||||||||
| NLwith(agents = agents, var = var, val = maxVal) | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Agents with minimum | ||||||||
| #' | ||||||||
| #' Report the patches or turtles among \code{agents} which have their variable | ||||||||
| #' equals to the minimum value. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2) with the first column "pxcor" and the second column | ||||||||
| #' "pycor" representing the coordinates of the patches among the \code{agents} | ||||||||
| #' which have their variable | ||||||||
| #' equal to the minimum value among the \code{agents}, or | ||||||||
| #' | ||||||||
| #' SpatialPointsDataFrame representing the turtles among the \code{agents} | ||||||||
| #' which have their variable | ||||||||
| #' \code{var} equal to the minimum value among the \code{agents}. | ||||||||
| #' | ||||||||
| #' @details \code{world} must not be provided if \code{agents} are turtles. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#with-min} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # Patches | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = sample(1:5, size = count(patches(w1)), replace = TRUE)) | ||||||||
| #' plot(w1) | ||||||||
| #' p1 <- withMin(agents = patches(w1), world = w1) | ||||||||
| #' | ||||||||
| #' # Turtles | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10), heading = sample(1:3, size = 10, replace= TRUE)) | ||||||||
| #' t2 <- withMin(agents = t1, var = "heading") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname withMin | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "withMin", | ||||||||
| function(agents, world, var) { | ||||||||
| standardGeneric("withMin") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname withMin | ||||||||
| setMethod( | ||||||||
| "withMin", | ||||||||
| signature = c("matrix", "NLworld", "missing"), | ||||||||
| definition = function(agents, world) { | ||||||||
| val <- of(world = world, agents = agents) | ||||||||
| if(length(val[is.na(val)]) == length(val)){ | ||||||||
| stop("patches' values are all NAs") | ||||||||
| } else { | ||||||||
| minVal <- min(val, na.rm = TRUE) | ||||||||
| NLwith(agents = agents, world = world, val = minVal) | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname withMin | ||||||||
| setMethod( | ||||||||
| "withMin", | ||||||||
| signature = c("matrix", "NLworldStack", "character"), | ||||||||
| definition = function(agents, world, var) { | ||||||||
| names_l <- names(world) | ||||||||
| l <- match(var, names_l) | ||||||||
| world_l <- world[[l]] | ||||||||
| withMin(world = world_l, agents = agents) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname withMin | ||||||||
| setMethod( | ||||||||
| "withMin", | ||||||||
| signature = c("SpatialPointsDataFrame", "missing", "character"), | ||||||||
| definition = function(agents, var) { | ||||||||
| val_var <- of(agents = agents, var = var) | ||||||||
| if(length(val_var[is.na(val_var)] == length(val_var))){ | ||||||||
| stop("var equals to NA") | ||||||||
| } else { | ||||||||
| minVal = min(val_var, na.rm = TRUE) | ||||||||
| NLwith(agents = agents, var = var, val = minVal) | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' One agent with maximum | ||||||||
| #' | ||||||||
| #' Report one patch or one turtle among \code{agents} which has its variable equals | ||||||||
| #' to the maximum value. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2, nrow = 1) with the first column "pxcor" and | ||||||||
| #' the second column "pycor" representing the coordinates of the patch | ||||||||
| #' (or of one of the patches) among the \code{agents} which has its variable | ||||||||
| #' equals to the maximum value | ||||||||
| #' among the \code{agents}, or | ||||||||
| #' | ||||||||
| #' SpatialPointsDataFrame of length 1 representing the turtle (or one of | ||||||||
| #' the turtles) among the \code{agents} which has its variable \code{var} | ||||||||
| #' equals to the maximum value | ||||||||
| #' among the \code{agents}. | ||||||||
| #' | ||||||||
| #' @details \code{world} must not be provided if \code{agents} are turtles. | ||||||||
| #' | ||||||||
| #' If there are several patches or turtles among \code{agents} with their | ||||||||
| #' variable equal to the maximum | ||||||||
| #' value, one is chosen randomly. To access to all patches or turtles among | ||||||||
| #' \code{agents} which have their variable equal | ||||||||
| #' to the maximum value, use \code{withMax()}. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#max-one-of} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # Patches | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = sample(1:5, size = count(patches(w1)), replace = TRUE)) | ||||||||
| #' plot(w1) | ||||||||
| #' p1 <- maxOneOf(agents = patches(w1), world = w1) | ||||||||
| #' | ||||||||
| #' # Turtles | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10), heading = sample(1:3, size = 10, replace= TRUE)) | ||||||||
| #' t2 <- maxOneOf(agents = t1, var = "heading") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname maxOneOf | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "maxOneOf", | ||||||||
| function(agents, world, var) { | ||||||||
| standardGeneric("maxOneOf") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname maxOneOf | ||||||||
| setMethod( | ||||||||
| "maxOneOf", | ||||||||
| signature = c("matrix", "NLworld", "missing"), | ||||||||
| definition = function(agents, world) { | ||||||||
| maxAgents <- withMax(world = world, agents = agents) | ||||||||
| row <- sample(1:nrow(maxAgents), size = 1) | ||||||||
| maxAgent <- maxAgents[row,] | ||||||||
| return(cbind(pxcor = maxAgent[1], pycor = maxAgent[2])) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname maxOneOf | ||||||||
| setMethod( | ||||||||
| "maxOneOf", | ||||||||
| signature = c("matrix", "NLworldStack", "character"), | ||||||||
| definition = function(agents, world, var) { | ||||||||
| pos_l <- which(names(world) == var, TRUE) # find the layer | ||||||||
| world_l <- world[[pos_l]] | ||||||||
| maxOneOf(agents = agents, world = world_l) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname maxOneOf | ||||||||
| setMethod( | ||||||||
| "maxOneOf", | ||||||||
| signature = c("SpatialPointsDataFrame", "missing", "character"), | ||||||||
| definition = function(agents, var) { | ||||||||
| maxAgents <- withMax(agents = agents, var = var) | ||||||||
| if(length(maxAgents) == 1){ | ||||||||
| return(maxAgents) | ||||||||
| } else { | ||||||||
| whoSample <- sample(maxAgents@data$who, size = 1) | ||||||||
| turtle(turtles = maxAgents, who = whoSample) | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' One agent with minimum | ||||||||
| #' | ||||||||
| #' Report one patch or one turtle among \code{agents} which has its variable equals | ||||||||
| #' to the minimum value. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2, nrow = 1) with the first column "pxcor" and | ||||||||
| #' the second column "pycor" representing the coordinates of the patch | ||||||||
| #' (or of one of the patches) among the \code{agents} which has its variable | ||||||||
| #' equals to the minimum value | ||||||||
| #' among the \code{agents}, or | ||||||||
| #' | ||||||||
| #' SpatialPointsDataFrame of length 1 representing the turtle (or one of | ||||||||
| #' the turtles) among the \code{agents} which has its variable \code{var} | ||||||||
| #' equals to the minimum value | ||||||||
| #' among the \code{agents}. | ||||||||
| #' | ||||||||
| #' @details \code{world} must not be provided if \code{agents} are turtles. | ||||||||
| #' | ||||||||
| #' If there are several patches or turtles among \code{agents} with their | ||||||||
| #' variable equal to the minimum | ||||||||
| #' value, one is chosen randomly. To access to all patches or turtles among | ||||||||
| #' \code{agents} which have their variable equal | ||||||||
| #' to the minimum value, use \code{withMin()}. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#min-one-of} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # Patches | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = sample(1:5, size = count(patches(w1)), replace = TRUE)) | ||||||||
| #' plot(w1) | ||||||||
| #' p1 <- minOneOf(agents = patches(w1), world = w1) | ||||||||
| #' | ||||||||
| #' # Turtles | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10), heading = sample(1:3, size = 10, replace= TRUE)) | ||||||||
| #' t2 <- minOneOf(agents = t1, var = "heading") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname minOneOf | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "minOneOf", | ||||||||
| function(agents, world, var) { | ||||||||
| standardGeneric("minOneOf") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname minOneOf | ||||||||
| setMethod( | ||||||||
| "minOneOf", | ||||||||
| signature = c("matrix", "NLworld", "missing"), | ||||||||
| definition = function(agents, world) { | ||||||||
| minAgents <- withMin(world = world, agents = agents) | ||||||||
| row <- sample(1:nrow(minAgents), size = 1) | ||||||||
| minAgent <- minAgents[row,] | ||||||||
| return(cbind(pxcor = minAgent[1], minAgent[2])) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname minOneOf | ||||||||
| setMethod( | ||||||||
| "minOneOf", | ||||||||
| signature = c("matrix", "NLworldStack", "character"), | ||||||||
| definition = function(agents, world, var) { | ||||||||
| pos_l <- which(names(world) == var, TRUE) # find the layer | ||||||||
| world_l <- world[[pos_l]] | ||||||||
| minOneOf(agents = agents, world = world_l) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname minOneOf | ||||||||
| setMethod( | ||||||||
| "minOneOf", | ||||||||
| signature = c("SpatialPointsDataFrame", "missing", "character"), | ||||||||
| definition = function(agents, var) { | ||||||||
| minAgents <- withMin(agents = agents, var = var) | ||||||||
| if(length(minAgents) == 1){ | ||||||||
| return(minAgents) | ||||||||
| } else { | ||||||||
| whoSample <- sample(minAgents@data$who, size = 1) | ||||||||
| turtle(turtles = minAgents, who = whoSample) | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Type of object | ||||||||
| #' | ||||||||
| #' Report \code{TRUE} if the \code{agents} is of the \code{class} tested, | ||||||||
| #' report \code{FALSE} otherwise. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param class Character. Can take one of the following options to define | ||||||||
| #' the \code{class}: \code{"agent"}, \code{"agentset"}, | ||||||||
| #' \code{"patch"}, \code{"patchset"}. \code{"turtle"} or \code{"turtleset"}. | ||||||||
| #' | ||||||||
| #' @return Logical. \code{TRUE} if \code{agents} is of the \code{class} tested. | ||||||||
| #' | ||||||||
| #' @details Careful! The \code{class} tested does not correspond to actual R classes. | ||||||||
| #' | ||||||||
| #' \code{agents} is \code{"patch"} if it is a matrix (ncol = 2) with the | ||||||||
| #' first column "pxcor" and the second column "pycor" with only | ||||||||
| #' one row. \code{agents} is \code{"patcheset"} if the matrix has more than | ||||||||
| #' one row. | ||||||||
| #' | ||||||||
| #' \code{agents} is \code{"turtle"} if it is a SpatialPointsDataFrame | ||||||||
| #' of length 1 with the variables created when using \code{createTurtles()} | ||||||||
| #' or \code{createOTurtles()}. \code{agents} is \code{"turtleset"} if the | ||||||||
| #' SpatialPointsDataFrame is of length larger than 1. | ||||||||
| #' | ||||||||
| #' \code{agents} is \code{"agent"} if it is either \code{"patch"} or | ||||||||
| #' \code{"turtle"}. \code{agents} is \code{"agentset"} if it is either | ||||||||
| #' \code{"patcheset"} or \code{"turtleset"}. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#is-of-type} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10), heading = sample(1:3, size = 10, replace= TRUE)) | ||||||||
| #' isNLclass(agents = patches(w1), class = "patch") | ||||||||
| #' isNLclass(agents = patches(w1), class = "patcheset") | ||||||||
| #' isNLclass(agents = t1, class = "agentset") | ||||||||
| #' isNLclass(agents = t1, class = "turtleset") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname isNLclass | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "isNLclass", | ||||||||
| function(agents, class) { | ||||||||
| standardGeneric("isNLclass") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname isNLclass | ||||||||
| setMethod( | ||||||||
| "isNLclass", | ||||||||
| signature = c("matrix", "character"), | ||||||||
| definition = function(agents, class) { | ||||||||
| # If it is this signature, it is a matrix, therefore patch or patches | ||||||||
| if(class == "agent"){ | ||||||||
| class <- "patch" | ||||||||
| } | ||||||||
| if(class == "agentset"){ | ||||||||
| class <- "patchset" | ||||||||
| } | ||||||||
| if((colnames(agents) == c("pxcor", "pycor") && nrow(agents) != 0)){ | ||||||||
| if(nrow(agents) == 1){ | ||||||||
| agentsClass <- "patch" | ||||||||
| } else { | ||||||||
| agentsClass <- "patchset" | ||||||||
| } | ||||||||
| } else { | ||||||||
| agentsClass <- "nothing" | ||||||||
| } | ||||||||
| matchClass <- ifelse(class == agentsClass, TRUE, FALSE) | ||||||||
| return(matchClass) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname isNLclass | ||||||||
| setMethod( | ||||||||
| "isNLclass", | ||||||||
| signature = c("SpatialPointsDataFrame", "character"), | ||||||||
| definition = function(agents, class) { | ||||||||
| # If it is this signature, it is a SPDF, therefore turtle or turtles | ||||||||
| if(class == "agent"){ | ||||||||
| class <- "turtle" | ||||||||
| } | ||||||||
| if(class == "agentset"){ | ||||||||
| class <- "turtleset" | ||||||||
| } | ||||||||
| if((colnames(agents@data[1:6]) == c("who", "heading", "prevX", "prevY", "breed", "color") && length(agents) != 0)){ | ||||||||
| if(length(agents) == 1){ | ||||||||
| agentsClass <- "turtle" | ||||||||
| } else { | ||||||||
| agentsClass <- "turtleset" | ||||||||
| } | ||||||||
| } else { | ||||||||
| agentsClass <- "nothing" | ||||||||
| } | ||||||||
| matchClass <- ifelse(class == agentsClass, TRUE, FALSE) | ||||||||
| return(matchClass) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' N random agents | ||||||||
| #' | ||||||||
| #' Report \code{n} patches or turtles randomly selected among \code{agents}. | ||||||||
| #' | ||||||||
| #' @inheritParams oneOf | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2, nrow = \code{n}) with the first column "pxcor" | ||||||||
| #' and the second column "pycor" representing the coordinates of the | ||||||||
| #' selected patches from \code{agents}, or | ||||||||
| #' | ||||||||
| #' Matrix (ncol = 2) with the first column "pxcor" | ||||||||
| #' and the second column "pycor" representing the coordinates of the | ||||||||
| #' selected patches from \code{agents}, \code{n} per individual "id", or | ||||||||
| #' | ||||||||
| #' SpatialPointsDataFrame of length \code{n} representing the turtles | ||||||||
| #' selected from \code{agents}, | ||||||||
| #' | ||||||||
| #' Integer. Vector of "who" numbers for the selected turtles from | ||||||||
| #' \code{agents}, \code{n} per individual "id". | ||||||||
| #' | ||||||||
| #' @details \code{n} must be less or equal the number of patches (per "id" | ||||||||
| #' if provided) or turtles in \code{agents}. | ||||||||
| #' | ||||||||
| #' If \code{agents} is a matrix with ncol = 3, the selection of \code{n} | ||||||||
| #' random patches is done per individual "id". The order of the patches | ||||||||
| #' coordinates returned follow the order of "id". | ||||||||
| #' If \code{agents} is a matrix (ncol = 2) with columns "whoTurtles" and | ||||||||
| #' "id", the selection of \code{n} random turtles (defined by their "whoTurtles") | ||||||||
| #' is done per individual "id". The order of the "who" numbers returned | ||||||||
| #' follow the order of "id". | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#n-of} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # Patches | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' pSelect <- nOf(agents = patches(w1), n = 5) | ||||||||
| #' | ||||||||
| #' # Turtles | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10)) | ||||||||
| #' tSelect <- nOf(agents = t1, n = 2) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname nOf | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "nOf", | ||||||||
| function(agents, n) { | ||||||||
| standardGeneric("nOf") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname nOf | ||||||||
| setMethod( | ||||||||
| "nOf", | ||||||||
| signature = c("matrix", "numeric"), | ||||||||
| definition = function(agents, n) { | ||||||||
| if(ncol(agents) == 2 & colnames(agents)[1] == "pxcor"){ | ||||||||
| row <- sample(1:nrow(agents), size = n, replace = FALSE) | ||||||||
| row <- row[order(row)] | ||||||||
| patches <- agents[row,] | ||||||||
| if(length(row) == 1){ # to keep the class = matrix | ||||||||
| patches <- cbind(pxcor = patches[1], pycor = patches[2]) | ||||||||
| } | ||||||||
| return(patches) | ||||||||
| } else { | ||||||||
| if(min(table(agents[, "id"])) < n){ | ||||||||
| stop("n is larger than the number of agents per id") | ||||||||
| } else { | ||||||||
| if(ncol(agents) == 3){ | ||||||||
| row <- tapply(X = 1:nrow(agents), INDEX = as.factor(agents[, "id"]), | ||||||||
| FUN = function(x){sample(x, size = n, replace = FALSE)}) | ||||||||
| patches <- agents[unlist(row), c("pxcor", "pycor")] | ||||||||
| return(patches) | ||||||||
| } else { | ||||||||
| row <- tapply(X = 1:nrow(agents), INDEX = as.factor(agents[, "id"]), | ||||||||
| FUN = function(x){sample(x, size = n, replace = FALSE)}) | ||||||||
| turtles <- agents[unlist(row), "whoTurtles"] | ||||||||
| return(turtles) | ||||||||
| } | ||||||||
| } | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname nOf | ||||||||
| setMethod( | ||||||||
| "nOf", | ||||||||
| signature = c("SpatialPointsDataFrame", "numeric"), | ||||||||
| definition = function(agents, n) { | ||||||||
| row <- sample(1:length(agents), size = n, replace = FALSE) | ||||||||
| row <- row[order(row)] | ||||||||
| newCoords <- agents@coords[row,] | ||||||||
| newData <- agents@data[row,] | ||||||||
| if(length(row) == 1){ # to keep the class = matrix | ||||||||
| newCoords <- cbind(xcor = newCoords[1], ycor = newCoords[2]) | ||||||||
| } | ||||||||
| newTurtles <- SpatialPointsDataFrame(coords = newCoords, data = newData) | ||||||||
| return(newTurtles) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' One random agent | ||||||||
| #' | ||||||||
| #' Report one patch or turtle randomly selected among \code{agents}. | ||||||||
| #' | ||||||||
| #' @param agents Matrix (ncol = 2) with the first column "pxcor" and the second | ||||||||
| #' column "pycor" representing the patches coordinates, or | ||||||||
| #' | ||||||||
| #' Matrix (ncol = 3) with the first column "pxcor" and the second | ||||||||
| #' column "pycor" representing the patches coordinates and the | ||||||||
| #' third column "id", or | ||||||||
| #' | ||||||||
| #' SpatialPointsDataFrame created by \code{createTurtles()} or | ||||||||
| #' by \code{createOTurtles()} representing the moving agents, or | ||||||||
| #' | ||||||||
| #' Matrix (ncol = 2) with the first column "whoTurtles" and the | ||||||||
| #' second column "id". | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2, nrow = 1) with the first column "pxcor" | ||||||||
| #' and the second column "pycor" representing the coordinates of the | ||||||||
| #' selected patch from \code{agents}, or | ||||||||
| #' | ||||||||
| #' Matrix (ncol = 2) with the first column "pxcor" | ||||||||
| #' and the second column "pycor" representing the coordinates of the | ||||||||
| #' selected patches from \code{agents}, one per individual "id", or | ||||||||
| #' | ||||||||
| #' SpatialPointsDataFrame of length 1 representing the turtle | ||||||||
| #' selected from \code{agents}, or | ||||||||
| #' | ||||||||
| #' Integer. Vector of "who" numbers for the selected turtles from | ||||||||
| #' \code{agents}, one per individual "id". | ||||||||
| #' | ||||||||
| #' @details If \code{agents} is a matrix with ncol = 3, the selection of one | ||||||||
| #' random patch is done per individual "id". The order of the patches | ||||||||
| #' coordinates returned follow the order of "id". | ||||||||
| #' If \code{agents} is a matrix (ncol = 2) with columns "whoTurtles" and | ||||||||
| #' "id", the selection of one random turtle (defined by their "whoTurtles") | ||||||||
| #' is done per individual "id". The order of the "who" numbers returned | ||||||||
| #' follow the order of "id". | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#one-of} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # Patches | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' pSelect <- oneOf(agents = patches(w1)) | ||||||||
| #' | ||||||||
| #' # Turtles | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10)) | ||||||||
| #' tSelect <- oneOf(agents = t1) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @importFrom Hmisc mApply | ||||||||
| #' @docType methods | ||||||||
| #' @rdname oneOf | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "oneOf", | ||||||||
| function(agents) { | ||||||||
| standardGeneric("oneOf") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname oneOf | ||||||||
| setMethod( | ||||||||
| "oneOf", | ||||||||
| signature = c("matrix"), | ||||||||
| definition = function(agents) { | ||||||||
| if(ncol(agents) == 2 & colnames(agents)[1] == "pxcor"){ | ||||||||
| nOf(agents = agents, n = 1) | ||||||||
| } else if(ncol(agents) == 3){ | ||||||||
| mApply(X = agents[, c("pxcor", "pycor")], INDEX = as.factor(agents[, "id"]), FUN = oneOf, keepmatrix = TRUE) | ||||||||
| } else { | ||||||||
| whoTurtles <- tapply(X = agents[,"whoTurtles"], INDEX = as.factor(agents[, "id"]), | ||||||||
| FUN = function(x){ifelse(length(x) == 1, x, sample(x, size = 1))}) | ||||||||
| return(as.numeric(whoTurtles)) | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname oneOf | ||||||||
| setMethod( | ||||||||
| "oneOf", | ||||||||
| signature = c("SpatialPointsDataFrame"), | ||||||||
| definition = function(agents) { | ||||||||
| nOf(agents = agents, n = 1) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' N agents with maximum | ||||||||
| #' | ||||||||
| #' Report the \code{n} patches or turtles among \code{agents} which have their variable | ||||||||
| #' among the maximum values. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2, nrow = \code{n}) with the first column "pxcor" and | ||||||||
| #' the second column "pycor" representing the coordinates of the \code{n} | ||||||||
| #' patches among the \code{agents} which have their variable values among | ||||||||
| #' the maximum values among the | ||||||||
| #' \code{agents}, or | ||||||||
| #' | ||||||||
| #' SpatialPointsDataFrame of length \code{n} representing the turtles among the | ||||||||
| #' \code{agents} which | ||||||||
| #' have their \code{var} values among the maximum values among the \code{agents}. | ||||||||
| #' | ||||||||
| #' @details \code{world} must not be provided if \code{agents} are turtles. | ||||||||
| #' | ||||||||
| #' If there is a tie that would make the number of returned patches or turtles larger | ||||||||
| #' than \code{n}, it is broken randomly. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#max-n-of} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # Patches | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = sample(1:10, size = count(patches(w1)), replace = TRUE)) | ||||||||
| #' plot(w1) | ||||||||
| #' p1 <- maxNof(agents = patches(w1), n = 6, world = w1) | ||||||||
| #' | ||||||||
| #' # Turtles | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10), heading = sample(1:5, size = 10, replace= TRUE)) | ||||||||
| #' t2 <- maxNof(agents = t1, n = 5, var = "heading") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname maxNof | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "maxNof", | ||||||||
| function(agents, n, world, var) { | ||||||||
| standardGeneric("maxNof") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname maxNof | ||||||||
| setMethod( | ||||||||
| "maxNof", | ||||||||
| signature = c("matrix", "numeric", "NLworld", "missing"), | ||||||||
| definition = function(agents, n, world) { | ||||||||
| if(n == 1){ | ||||||||
| maxOneOf(agents = agents, world = world) | ||||||||
| } else if(n == 0){ | ||||||||
| noPatches() | ||||||||
| } else if(n == nrow(agents)){ | ||||||||
| return(agents) | ||||||||
| } else { | ||||||||
| val <- of(world = world, agents = agents) | ||||||||
| agentsVal <- cbind(val, agents) | ||||||||
| agentsVal <- agentsVal[order(-agentsVal[,"val"]),] # decreasing order | ||||||||
| minVal <- min(agentsVal[1:n, "val"], na.rm = TRUE) | ||||||||
| maxAgents <- agentsVal[agentsVal[,"val"] >= minVal,] | ||||||||
| # To break ties randomly | ||||||||
| if(nrow(maxAgents) != n){ | ||||||||
| nToRemove <- nrow(maxAgents) - n # how many ties to remove | ||||||||
| toKeep <- sample(1:nrow(maxAgents[maxAgents[,"val"] == minVal,]), | ||||||||
| size = nrow(maxAgents[maxAgents[,"val"] == minVal,]) -nToRemove) # rows to keep | ||||||||
| maxAgents <- rbind(maxAgents[maxAgents[,"val"] > minVal,], maxAgents[maxAgents[,"val"] == minVal,][toKeep,]) | ||||||||
| } | ||||||||
| return(cbind(pxcor = maxAgents[,"pxcor"], pycor = maxAgents[,"pycor"])) | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname maxNof | ||||||||
| setMethod( | ||||||||
| "maxNof", | ||||||||
| signature = c("matrix", "numeric", "NLworldStack", "character"), | ||||||||
| definition = function(agents, n, world, var) { | ||||||||
| pos_l <- which(names(world) == var, TRUE) # find the layer | ||||||||
| world_l <- world[[pos_l]] | ||||||||
| maxNof(agents = agents, n = n, world = world_l) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname maxNof | ||||||||
| setMethod( | ||||||||
| "maxNof", | ||||||||
| signature = c("SpatialPointsDataFrame", "numeric", "missing", "character"), | ||||||||
| definition = function(agents, n, var) { | ||||||||
| if(n == 1){ | ||||||||
| maxOneOf(agents = agents, var = var) | ||||||||
| } else if(n == 0){ | ||||||||
| noTurtles() | ||||||||
| } else if(n == length(agents)){ | ||||||||
| return(agents) | ||||||||
| } else { | ||||||||
| tData <- agents@data | ||||||||
| rownames(tData) <- 1:nrow(tData) | ||||||||
| tData <- tData[order(-tData[,var]),] # decreasing order | ||||||||
| minVal <- min(tData[1:n, var], na.rm = TRUE) | ||||||||
| maxAgents <- tData[tData[,var] >= minVal,] | ||||||||
| # To break ties randomly | ||||||||
| if(nrow(maxAgents) != n){ | ||||||||
| nToRemove <- nrow(maxAgents) - n # how many ties to remove | ||||||||
| toKeep <- sample(1:nrow(maxAgents[maxAgents[,var] == minVal,]), | ||||||||
| size = nrow(maxAgents[maxAgents[,var] == minVal,]) -nToRemove) # rows to keep | ||||||||
| maxAgents <- rbind(maxAgents[maxAgents[,var] > minVal,], maxAgents[maxAgents[,var] == minVal,][toKeep,]) | ||||||||
| } | ||||||||
| tSelect <- as.numeric(rownames(maxAgents)) | ||||||||
| tSelect <- sort(tSelect) | ||||||||
| tSelectCoords <- cbind(xcor = agents@coords[tSelect,1], ycor = agents@coords[tSelect,2]) | ||||||||
| tSelectData <- agents@data[tSelect,] | ||||||||
| maxTurtles <- SpatialPointsDataFrame(coords = tSelectCoords, data = tSelectData) | ||||||||
| return(maxTurtles) | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' N agents with minimum | ||||||||
| #' | ||||||||
| #' Report the \code{n} patches or turtles among \code{agents} which have their variable | ||||||||
| #' among the minimum values. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2, nrow = \code{n}) with the first column "pxcor" and | ||||||||
| #' the second column "pycor" representing the coordinates of the \code{n} | ||||||||
| #' patches among the \code{agents} which have their variable values among | ||||||||
| #' the minimum values among the | ||||||||
| #' \code{agents}, or | ||||||||
| #' | ||||||||
| #' SpatialPointsDataFrame of length \code{n} representing the turtles among the | ||||||||
| #' \code{agents} which | ||||||||
| #' have their \code{var} values among the minimum values among the \code{agents}. | ||||||||
| #' | ||||||||
| #' @details \code{world} must not be provided if \code{agents} are turtles. | ||||||||
| #' | ||||||||
| #' If there is a tie that would make the number of returned patches or turtles larger | ||||||||
| #' than \code{n}, it is broken randomly. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#min-n-of} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # Patches | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = sample(1:10, size = count(patches(w1)), replace = TRUE)) | ||||||||
| #' plot(w1) | ||||||||
| #' p1 <- minNof(agents = patches(w1), n = 6, world = w1) | ||||||||
| #' | ||||||||
| #' # Turtles | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10), heading = sample(1:5, size = 10, replace= TRUE)) | ||||||||
| #' t2 <- minNof(agents = t1, n = 5, var = "heading") | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname minNof | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "minNof", | ||||||||
| function(agents, n, world, var) { | ||||||||
| standardGeneric("minNof") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname minNof | ||||||||
| setMethod( | ||||||||
| "minNof", | ||||||||
| signature = c("matrix", "numeric", "NLworld", "missing"), | ||||||||
| definition = function(agents, n, world) { | ||||||||
| if(n == 1){ | ||||||||
| minOneOf(agents = agents, world = world) | ||||||||
| } else if(n == 0){ | ||||||||
| noPatches() | ||||||||
| } else if(n == nrow(agents)){ | ||||||||
| return(agents) | ||||||||
| } else { | ||||||||
| maxPatches <- maxNof(agents = agents, n = nrow(agents) - n, world = world) | ||||||||
| other(agents = agents, except = maxPatches) | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname minNof | ||||||||
| setMethod( | ||||||||
| "minNof", | ||||||||
| signature = c("matrix", "numeric", "NLworldStack", "character"), | ||||||||
| definition = function(agents, n, world, var) { | ||||||||
| pos_l <- which(names(world) == var, TRUE) # find the layer | ||||||||
| world_l <- world[[pos_l]] | ||||||||
| minNof(agents = agents, n = n, world = world_l) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname minNof | ||||||||
| setMethod( | ||||||||
| "minNof", | ||||||||
| signature = c("SpatialPointsDataFrame", "numeric", "missing", "character"), | ||||||||
| definition = function(agents, n, var) { | ||||||||
| if(n == 1){ | ||||||||
| minOneOf(agents = agents, var = var) | ||||||||
| } else if(n == 0){ | ||||||||
| noTurtles() | ||||||||
| } else if(n == length(agents)){ | ||||||||
| return(agents) | ||||||||
| } else { | ||||||||
| maxTurtles <- maxNof(agents = agents, n = length(agents) - n, var = var) | ||||||||
| other(agents = agents, except = maxTurtles) | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Agents in radius | ||||||||
| #' | ||||||||
| #' Report the patches or turtles among \code{agents2} within given distances of | ||||||||
| #' each of the \code{agents}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param radius Numeric. Vector of distances from \code{agents} to locate | ||||||||
| #' \code{agents2}. Must be of length 1 or of length \code{agents}. | ||||||||
| #' | ||||||||
| #' @param agents2 Matrix (ncol = 2) with the first column "pxcor" and the second | ||||||||
| #' column "pycor" representing the patches coordinates, or | ||||||||
| #' | ||||||||
| #' SpatialPointsDataFrame created by \code{createTurtles()} or | ||||||||
| #' by \code{createOTurtles()} representing the moving agents. | ||||||||
| #' | ||||||||
| #' @return List of length equal to \code{count(agents)}. | ||||||||
| #' List items are matrices (ncol = 2) with the first column "pxcor" | ||||||||
| #' and the second column "pycor" representing the coordinates of the | ||||||||
| #' patches among \code{agents2} within \code{radius} distances for each \code{agents}, if | ||||||||
| #' \code{agents2} are patches, or SpatialPointsDataFrame objects representing | ||||||||
| #' the turtles among \code{agents2} within \code{radius} distances for each \code{agents} if | ||||||||
| #' \code{agents2} are turtles. | ||||||||
| #' | ||||||||
| #' @details Distances from/to patches are calculated from/to their center. | ||||||||
| #' | ||||||||
| #' If \code{torus = FALSE}, \code{world} does not need to be provided. | ||||||||
| #' | ||||||||
| #' If \code{torus = TRUE}, the \code{radius} distances are calculared | ||||||||
| #' around the sides of the \code{world} to select \code{agents2}. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#in-radius} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10)) | ||||||||
| #' | ||||||||
| #' p1 <- inRadius(agents = patch(w1, 0, 0), radius = 2, agents2 = patches(w1)) | ||||||||
| #' t2 <- inRadius(agents = patch(w1, 0, 0), radius = 2, agents2 = t1) | ||||||||
| #' p2 <- inRadius(agents = t1, radius = 2, agents2 = patches(w1)) | ||||||||
| #' t3 <- inRadius(agents = turtle(t1, who = 0), radius = 2, agents2 = t1) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @importFrom rgeos gBuffer | ||||||||
| #' @importFrom sp over | ||||||||
| #' @importFrom SpaDES wrap | ||||||||
| #' @docType methods | ||||||||
| #' @rdname inRadius | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "inRadius", | ||||||||
| function(agents, radius, agents2, world, torus = FALSE) { | ||||||||
| standardGeneric("inRadius") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname inRadius | ||||||||
| setMethod( | ||||||||
| "inRadius", | ||||||||
| signature = c(agents = "matrix", radius = "numeric", agents2 = "matrix"), | ||||||||
| definition = function(agents, radius, agents2, world, torus) { | ||||||||
| inRadius(agents = SpatialPointsDataFrame(coords = agents, data = data.frame(rep(NA, nrow(agents)))), radius = radius, agents2 = agents2, world = world, torus = torus) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname inRadius | ||||||||
| setMethod( | ||||||||
| "inRadius", | ||||||||
| signature = c(agents = "matrix", radius = "numeric", agents2 = "SpatialPointsDataFrame"), | ||||||||
| definition = function(agents, radius, agents2, world, torus) { | ||||||||
| inRadius(agents = SpatialPointsDataFrame(coords = agents, data = data.frame(rep(NA, nrow(agents)))), radius = radius, agents2 = agents2, world = world, torus = torus) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname inRadius | ||||||||
| setMethod( | ||||||||
| "inRadius", | ||||||||
| signature = c(agents = "SpatialPointsDataFrame", radius = "numeric", agents2 = "matrix"), | ||||||||
| definition = function(agents, radius, agents2, world, torus) { | ||||||||
| # Create buffers around the locations of agents | ||||||||
| pBuffer <- gBuffer(agents, byid = TRUE, id = 1:length(agents), width = radius, quadsegs = 50) | ||||||||
| if(torus == TRUE){ | ||||||||
| if(missing(world)){ | ||||||||
| stop("A world must be provided as torus = TRUE") | ||||||||
| } | ||||||||
| worldWrap <- createNLworld(minPxcor = minPxcor(world) - radius, maxPxcor = maxPxcor(world) + radius, | ||||||||
| minPycor = minPycor(world) - radius, maxPycor = maxPycor(world) + radius) | ||||||||
| pAllWrap <- patches(worldWrap) | ||||||||
| # Extract the locations of agents2 under the buffers | ||||||||
| pOver <- over(pBuffer, SpatialPoints(coords = pAllWrap), returnList = TRUE) | ||||||||
| list_agentsXY <- lapply(pOver, function(z){ | ||||||||
| wrap(cbind(x = pAllWrap[as.numeric(z), 1], y = pAllWrap[as.numeric(z), 2]), extent(world)) | ||||||||
| }) | ||||||||
| colnames(agents2) <- c("pxcor", "pycor") | ||||||||
| list_agents <- lapply(list_agentsXY, function(x){ | ||||||||
| colnames(x) <- c("pxcor", "pycor") | ||||||||
| as.matrix(merge(x, agents2)) | ||||||||
| }) | ||||||||
| } else { | ||||||||
| # Extract the locations of agents2 under the buffers | ||||||||
| pOver <- over(pBuffer, SpatialPoints(coords = agents2), returnList = TRUE) | ||||||||
| list_agents <- lapply(pOver, function(x){ | ||||||||
| cbind(pxcor = agents2[as.numeric(x), 1], pycor = agents2[as.numeric(x), 2]) | ||||||||
| }) | ||||||||
| } | ||||||||
| return(list_agents) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname inRadius | ||||||||
| setMethod( | ||||||||
| "inRadius", | ||||||||
| signature = c(agents = "SpatialPointsDataFrame", radius = "numeric", agents2 = "SpatialPointsDataFrame"), | ||||||||
| definition = function(agents, radius, agents2, world, torus) { | ||||||||
| # Create buffers around the locations of agents | ||||||||
| pBuffer <- gBuffer(agents, byid = TRUE, id = 1:length(agents), width = radius, quadsegs = 50) | ||||||||
| if(torus == TRUE){ | ||||||||
| if(missing(world)){ | ||||||||
| stop("A world must be provided as torus = TRUE") | ||||||||
| } | ||||||||
| agents2c <- agents2@coords | ||||||||
| agents2c1 <- cbind(agents2c[,1] - (world@extent@xmax - world@extent@xmin), agents2c[,2] + (world@extent@ymax - world@extent@ymin)) | ||||||||
| agents2c2 <- cbind(agents2c[,1], agents2c[,2] + (world@extent@ymax - world@extent@ymin)) | ||||||||
| agents2c3 <- cbind(agents2c[,1] + (world@extent@xmax - world@extent@xmin), agents2c[,2] + (world@extent@ymax - world@extent@ymin)) | ||||||||
| agents2c4 <- cbind(agents2c[,1] - (world@extent@xmax - world@extent@xmin), agents2c[,2]) | ||||||||
| agents2c5 <- cbind(agents2c[,1] + (world@extent@xmax - world@extent@xmin), agents2c[,2]) | ||||||||
| agents2c6 <- cbind(agents2c[,1] - (world@extent@xmax - world@extent@xmin), agents2c[,2] - (world@extent@ymax - world@extent@ymin)) | ||||||||
| agents2c7 <- cbind(agents2c[,1], agents2c[,2] - (world@extent@ymax - world@extent@ymin)) | ||||||||
| agents2c8 <- cbind(agents2c[,1] + (world@extent@xmax - world@extent@xmin), agents2c[,2] - (world@extent@ymax - world@extent@ymin)) | ||||||||
| agents2cAll <- rbind(agents2c, agents2c1, agents2c2, agents2c3, agents2c4, agents2c5, agents2c6, agents2c7, agents2c8) | ||||||||
| # Extract the locations of agents2 under the buffers | ||||||||
| pOver <- over(pBuffer, SpatialPoints(coords = agents2cAll), returnList = TRUE) | ||||||||
| list_agentsXY <- lapply(pOver, function(z){ | ||||||||
| unique(wrap(cbind(x = agents2cAll[as.numeric(z), 1], y = agents2cAll[as.numeric(z), 2]), extent(world))) | ||||||||
| }) | ||||||||
| list_agents <- lapply(list_agentsXY, function(x){ | ||||||||
| tWho <- merge(x, cbind(agents2@coords, agents2@data), by.x = c("x", "y"), by.y = c("xcor", "ycor")) | ||||||||
| turtle(turtles = agents2, who = tWho[,"who"]) | ||||||||
| }) | ||||||||
| } else { | ||||||||
| # Extract the locations of agents2 under the buffers | ||||||||
| pOver <- over(pBuffer, agents2, returnList = TRUE) | ||||||||
| list_agents <- lapply(pOver, function(x){ | ||||||||
| turtle(turtles = agents2, who = x[,"who"]) | ||||||||
| }) | ||||||||
| } | ||||||||
| return(list_agents) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Agents in cone | ||||||||
| #' | ||||||||
| #' Report the \code{agents} within the "cone of vision" in front of each one of the | ||||||||
| #' \code{turtles}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param radius Numeric. Vector of distances from \code{turtles} to locate | ||||||||
| #' \code{agents}. Must be of length 1 or of length \code{turtles}. | ||||||||
| #' | ||||||||
| #' @param angle Numeric. Vector of angles to define the size of the cone of vision | ||||||||
| #' for the \code{turtles}. The cone of vision is defined between the | ||||||||
| #' direction of their headings minus \code{angle / 2} | ||||||||
| #' to the direction of their headings plus \code{angle / 2}. Must be of length 1 or | ||||||||
| #' of length \code{turtles}. | ||||||||
| #' | ||||||||
| #' @return List of length equal to \code{length(turtles)}. | ||||||||
| #' List items are either matrices (ncol = 2) with the first column "pxcor" | ||||||||
| #' and the second column "pycor" representing the coordinates of the | ||||||||
| #' patches among \code{agents} within the cone of vision of each of the | ||||||||
| #' \code{turtles}, if \code{agents} are patches, | ||||||||
| #' or SpatialPointsDataFrame objects representing the turtles among \code{agents} | ||||||||
| #' within | ||||||||
| #' the cone of vision of each of the \code{turtles} if \code{agents} are turtles. | ||||||||
| #' | ||||||||
| #' @details \code{agents} are reported if there are within \code{radius} | ||||||||
| #' distance of the turtle and their direction from the turtle is within | ||||||||
| #' \code{[-angle, + angle]} of the turtle's heading. | ||||||||
| #' | ||||||||
| #' Distances to patches are calculated to their center. | ||||||||
| #' | ||||||||
| #' If \code{torus = FALSE}, \code{world} does not need to be provided. | ||||||||
| #' | ||||||||
| #' If \code{torus = TRUE}, the \code{radius} distances are calculated | ||||||||
| #' around the sides of the \code{world} to select \code{agents}. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#in-cone} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' t1 <- createTurtles(n = 10, coords = randomXYcor(w1, n = 10)) | ||||||||
| #' | ||||||||
| #' p1 <- inCone(turtles = t1, radius = 2, agents = patches(w1), angle = 90) | ||||||||
| #' t2 <- inCone(turtles = turtle(t1, who = 0), radius = 2, angle = 90, agents = t1) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname inCone | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "inCone", | ||||||||
| function(turtles, radius, angle, agents, world, torus = FALSE) { | ||||||||
| standardGeneric("inCone") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname inCone | ||||||||
| setMethod( | ||||||||
| "inCone", | ||||||||
| signature = c(turtles = "SpatialPointsDataFrame", radius = "numeric", angle = "numeric", agents = "matrix"), | ||||||||
| definition = function(turtles, radius, angle, agents, world, torus) { | ||||||||
| # Find the patches within distances | ||||||||
| agentsInRadius <- inRadius(agents = turtles, radius = radius, agents2 = agents, world = world, torus = torus) | ||||||||
| emptyL <- lapply(agentsInRadius, function(x){nrow(x)}) | ||||||||
| emptyElem <- as.numeric(do.call(rbind,emptyL)[,1]) | ||||||||
| if(sum(emptyElem) == 0){ # No patches are within radius distances for any turtles | ||||||||
| return(agentsInRadius) | ||||||||
| } else { | ||||||||
| agentsNoEmpty <- agentsInRadius[lapply(agentsInRadius,nrow) > 0] | ||||||||
| # Calculate the direction from each turtle to each one of the patches | ||||||||
| tList <- lapply(turtles@data$who, function(x){turtle(turtles, who = x)}) | ||||||||
| # Remove turtles which do not have patches within radius distance | ||||||||
| tList <- tList[lapply(agentsInRadius,nrow) > 0] | ||||||||
| # Direction from the turtle to each of their patches within radius distance | ||||||||
| tDir <- mapply(function(x, y){ | ||||||||
| towards(world = world, agents = x, agents2 = y, torus = torus) | ||||||||
| }, tList, agentsNoEmpty, SIMPLIFY = FALSE) | ||||||||
| # Define the rotation angle between the turtle heading and the direction to each patches | ||||||||
| tCone <- mapply(function(x, y){subHeadings(angle1 = x, angle2 = y, range360 = FALSE)}, tDir, tList, SIMPLIFY = FALSE) | ||||||||
| angle <- angle / 2 | ||||||||
| if(length(angle) == 1){ | ||||||||
| angle <- rep(angle, length(turtles)) | ||||||||
| } | ||||||||
| angleList <- split(angle, 1:length(angle)) | ||||||||
| # Remove the angle for the turtles which do not have patches within radius distance | ||||||||
| angleList <- angleList[lapply(agentsInRadius,nrow) > 0] | ||||||||
| # Is the rotation to face the patches smaller than the maximum rotation allowed | ||||||||
| tConeTRUE <- mapply(function(x, y){abs(x) < y}, tCone, angleList, SIMPLIFY = FALSE) | ||||||||
| pWithin <- lapply(tConeTRUE, function(x){which(x)}) | ||||||||
| list_agents <- mapply(function(x, y){ | ||||||||
| if(length(x) == 0){ | ||||||||
| noPatches() | ||||||||
| } else { | ||||||||
| cbind(pxcor = y[x, 1], pycor = y[x, 2]) | ||||||||
| } | ||||||||
| }, pWithin, agentsNoEmpty, SIMPLIFY = FALSE) | ||||||||
| # Reassign the results with the empty patches | ||||||||
| agentsInCone <- vector("list", length(turtles)) | ||||||||
| agentsInCone[which(emptyElem %in% 0)] <- list(noPatches()) | ||||||||
| agentsInCone[which(!emptyElem %in% 0)] <- list_agents | ||||||||
| return(agentsInCone) | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname inCone | ||||||||
| setMethod( | ||||||||
| "inCone", | ||||||||
| signature = c(turtles = "SpatialPointsDataFrame", radius = "numeric", angle = "numeric", agents = "SpatialPointsDataFrame"), | ||||||||
| definition = function(turtles, radius, angle, agents, world, torus) { | ||||||||
| pCoords <- inCone(turtles = turtles, radius = radius, angle = angle, agents = agents@coords, world = world, torus = torus) | ||||||||
| # Merge the coordinates within the cone to the turtles data | ||||||||
| tWho <- lapply(pCoords, function(x){merge(x, cbind(agents@coords, agents@data), by.x = c("pxcor", "pycor"), by.y = c("xcor", "ycor"))}) | ||||||||
| list_agents <- lapply(tWho, function(x){turtle(turtles = agents, who = x$who)}) | ||||||||
| return(list_agents) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Set an agents variable | ||||||||
| #' | ||||||||
| #' Assign values to the \code{agents} for their selected variables. | ||||||||
| #' | ||||||||
| #' @inheritParams of | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param val Numeric or character. Vector of length 1 or length \code{count(agents)} | ||||||||
| #' if \code{length(var) == 1}, or | ||||||||
| #' | ||||||||
| #' Matrix or Dataframe (ncol = \code{length(var)}, nrow = \code{count(agents)}). | ||||||||
| #' Columns must be in the same order as \code{var}. | ||||||||
| #' | ||||||||
| #' @return NLworlds object with the values \code{val} assigned to the patches variables \code{var} | ||||||||
| #' for the \code{agents}, or | ||||||||
| #' | ||||||||
| #' SpatialPointsDataFrame representing the \code{turtles} with | ||||||||
| #' the values \code{val} assigned to the variables \code{var} for the \code{agents}. | ||||||||
| #' | ||||||||
| #' @details If \code{agents} are patches, \code{world} must be provided and \code{turtles} | ||||||||
| #' must not be provided. If \code{agents} are turtles, \code{turtles} must be | ||||||||
| #' provided and \code{world} must not be provided. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#set} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = 1) | ||||||||
| #' w1 <- set(world = w1, agents = patch(w1, 0, 4), val = 0) # set the patch[0,0] to 0 | ||||||||
| #' of(world = w1, agents = patches(w1)) | ||||||||
| #' | ||||||||
| #' t1 <- createTurtles(n = 3, world = w1, heading = 0) | ||||||||
| #' t2 <- set(turtles = t1, agents = turtle(t1, who = 0), var = "heading", val = 180) # set the heading of the turtle 0 to 180 | ||||||||
| #' of(agents = t2, var = "heading") # c(180, 0, 0) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @importFrom prodlim row.match | ||||||||
| #' @docType methods | ||||||||
| #' @rdname set | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "set", | ||||||||
| function(world, turtles, agents, var, val) { | ||||||||
| standardGeneric("set") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname set | ||||||||
| setMethod( | ||||||||
| "set", | ||||||||
| signature = c(world = "NLworld", turtles = "missing", agents = "matrix", var = "missing", val = "ANY"), | ||||||||
| definition = function(world, agents, val) { | ||||||||
| if(count(agents) != 0){ | ||||||||
| if(identical(patches(world), agents)){ | ||||||||
| world[] <- val | ||||||||
| } else { | ||||||||
| valuesW <- values(world) | ||||||||
| cells <- cellFromPxcorPycor(world = world, pxcor = agents[,1], pycor = agents[,2]) | ||||||||
| valuesW[cells] <- val | ||||||||
| world[] <- valuesW | ||||||||
| } | ||||||||
| } | ||||||||
| return(world) | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname set | ||||||||
| setMethod( | ||||||||
| "set", | ||||||||
| signature = c(world = "NLworldStack", turtles = "missing", agents = "matrix", var = "character", val = "ANY"), | ||||||||
| definition = function(world, agents, var, val) { | ||||||||
| if(count(agents) != 0){ | ||||||||
| if(identical(patches(world), agents)){ | ||||||||
| if(length(var) == 1){ | ||||||||
| colNum <- match(var, names(world)) | ||||||||
| world@layers[[colNum]][] <- val | ||||||||
| } else { | ||||||||
| for(i in 1:length(var)){ | ||||||||
| colNum <- match(var[i], names(world)) | ||||||||
| world@layers[[colNum]][] <- val[,i] | ||||||||
| } | ||||||||
| } | ||||||||
| } else { | ||||||||
| valuesW <- values(world) | ||||||||
| cells <- cellFromPxcorPycor(world = world, pxcor = agents[,1], pycor = agents[,2]) | ||||||||
| if(length(var) == 1){ | ||||||||
| colNum <- match(var, colnames(valuesW)) | ||||||||
| valuesW[cells, colNum] <- val | ||||||||
| world@layers[[colNum]][] <- valuesW[,colNum] | ||||||||
| } else { | ||||||||
| for(i in 1:length(var)){ | ||||||||
| colNum <- match(var[i], colnames(valuesW)) | ||||||||
| valuesW[cells, colNum] <- val[,i] | ||||||||
| world@layers[[colNum]][] <- valuesW[,colNum] | ||||||||
| } | ||||||||
| } | ||||||||
| } | ||||||||
| } | ||||||||
| return(world) | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname set | ||||||||
| setMethod( | ||||||||
| "set", | ||||||||
| signature = c(world = "missing", turtles = "SpatialPointsDataFrame", agents = "SpatialPointsDataFrame", | ||||||||
| var = "character", val = "ANY"), | ||||||||
| definition = function(turtles, agents, var, val) { | ||||||||
| if(count(agents) != 0){ | ||||||||
| if(identical(agents, turtles)){ | ||||||||
| if(length(var) == 1){ | ||||||||
| if(var == "xcor"){ | ||||||||
| turtles@coords[, 1] <- val | ||||||||
| } else if(var == "ycor"){ | ||||||||
| turtles@coords[, 2] <- val | ||||||||
| } else { | ||||||||
| turtles@data[, var] <- val | ||||||||
| } | ||||||||
| } else { | ||||||||
| if(any(var == "xor" | var == "ycor")){ | ||||||||
| turtlesData <- cbind(turtles@coords, turtles@data) | ||||||||
| turtlesData[, var] <- val | ||||||||
| turtles@coords <- turtlesData[,c(1,2)] | ||||||||
| turtles@data <- turtlesData[,3:ncol(turtlesData)] | ||||||||
| } else { | ||||||||
| turtles@data[, var] <- val | ||||||||
| } | ||||||||
| } | ||||||||
| } else { | ||||||||
| iAgents <- row.match(agents@data, turtles@data) # using data.table is not faster | ||||||||
| if(length(var) == 1){ | ||||||||
| if(var == "xcor"){ | ||||||||
| turtles@coords[iAgents, 1] <- val | ||||||||
| } else if(var == "ycor"){ | ||||||||
| turtles@coords[iAgents, 2] <- val | ||||||||
| } else { | ||||||||
| turtles@data[iAgents, var] <- val | ||||||||
| } | ||||||||
| } else { | ||||||||
| if(any(var == "xcor" | var == "ycor")){ | ||||||||
| turtlesData <- cbind(turtles@coords, turtles@data) | ||||||||
| turtlesData[iAgents, var] <- val | ||||||||
| turtles@coords <- cbind(xcor = turtlesData[,1], ycor = turtlesData[,2]) | ||||||||
| turtles@data <- turtlesData[,3:ncol(turtlesData)] | ||||||||
| } else { | ||||||||
| turtles@data[iAgents, var] <- val | ||||||||
| } | ||||||||
| } | ||||||||
| } | ||||||||
| } | ||||||||
| return(turtles) | ||||||||
| }) | ||||||||
| C:\Eliot\GitHub\NetLogoR/R/world-functions.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| ################################################################################ | ||||||||
| #' Create a world | ||||||||
| #' | ||||||||
| #' Create an empty grid of patches of class NLworld. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return NLworld object composed of \code{(maxPxcor - minPxcor + 1) * (maxPycor - minPycor + 1)} | ||||||||
| #' patches. Patches value are \code{NA}. | ||||||||
| #' | ||||||||
| #' @details If no parameters value are provided, default values are: \code{minPxcor = -16}, | ||||||||
| #' \code{maxPxcor = 16}, \code{minPycor = -16}, and \code{maxPycor = 16}. | ||||||||
| #' | ||||||||
| #' See \code{help("NLworld-class")} for more details on the NLworld class. | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = runif(count(patches(w1)))) | ||||||||
| #' plot(w1) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname createNLworld | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "createNLworld", | ||||||||
| function(minPxcor, maxPxcor, minPycor, maxPycor) { | ||||||||
| standardGeneric("createNLworld") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname createNLworld | ||||||||
| setMethod( | ||||||||
| "createNLworld", | ||||||||
| signature = c("numeric", "numeric", "numeric", "numeric"), | ||||||||
| definition = function(minPxcor, maxPxcor, minPycor, maxPycor) { | ||||||||
| world <- new("NLworld", | ||||||||
| minPxcor = minPxcor, maxPxcor = maxPxcor, | ||||||||
| minPycor = minPycor, maxPycor = maxPycor) | ||||||||
| # define the raster coordinates with the NLworld extent | ||||||||
| world@extent@xmin <- minPxcor - 0.5 | ||||||||
| world@extent@xmax <- maxPxcor + 0.5 | ||||||||
| world@extent@ymin <- minPycor - 0.5 | ||||||||
| world@extent@ymax <- maxPycor + 0.5 | ||||||||
| res(world) <- 1 | ||||||||
| # define the patch coordinates with the raster row and column numbers | ||||||||
| world@pxcor = (minPxcor + colFromCell(world, 1:(world@nrows * world@ncols))) - 1 | ||||||||
| world@pycor = (maxPycor - rowFromCell(world, 1:(world@nrows * world@ncols))) + 1 | ||||||||
| return(world) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname createNLworld | ||||||||
| setMethod( | ||||||||
| "createNLworld", | ||||||||
| signature = c("missing", "missing", "missing", "missing"), | ||||||||
| definition = function() { | ||||||||
| createNLworld(-16, 16, -16, 16) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Convert a Raster* object into a NLworlds object | ||||||||
| #' | ||||||||
| #' Convert a RasterLayer object into a NLworld object or a RasterStack object | ||||||||
| #' into a NLworldStack object. | ||||||||
| #' | ||||||||
| #' @param raster RasterLayer or RasterStack object. | ||||||||
| #' | ||||||||
| #' @return NLworld or NLworldStack object depending on the input. | ||||||||
| #' Patches value are retained from the Raster* object. | ||||||||
| #' | ||||||||
| #' @details See \code{help("NLworlds-class")} for more details on the NLworlds | ||||||||
| #' classes. | ||||||||
| #' | ||||||||
| #' The \code{raster} is resampled to match the coordinates system and | ||||||||
| #' resolution of a NLworlds using the nearest neighbor method. The | ||||||||
| #' extent will be bigger by 1 on the width and on the height. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' r <- raster(nrows = 21, ncols = 21, xmn = 0, ymn = 0, res = 5) | ||||||||
| #' r[] <- runif(length(r)) | ||||||||
| #' plot(r) | ||||||||
| #' extent(r) | ||||||||
| #' | ||||||||
| #' world <- convertNLworld(raster = r) | ||||||||
| #' plot(world) | ||||||||
| #' extent(world) | ||||||||
| #' minPxcor(world) | ||||||||
| #' maxPxcor(world) | ||||||||
| #' minPycor(world) | ||||||||
| #' maxPycor(world) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname convertNLworld | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "convertNLworld", | ||||||||
| function(raster) { | ||||||||
| standardGeneric("convertNLworld") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname convertNLworld | ||||||||
| setMethod( | ||||||||
| "convertNLworld", | ||||||||
| signature = c("RasterLayer"), | ||||||||
| definition = function(raster) { | ||||||||
| minPxcor <- round(raster@extent@xmin) | ||||||||
| maxPxcor <- round(raster@extent@xmax) | ||||||||
| minPycor <- round(raster@extent@ymin) | ||||||||
| maxPycor <- round(raster@extent@ymax) | ||||||||
| world <- createNLworld(minPxcor = minPxcor, maxPxcor = maxPxcor, minPycor = minPycor, maxPycor = maxPycor) | ||||||||
| worldR <- resample(raster, world, method = "ngb") | ||||||||
| worldNL <- as(worldR, "NLworld") | ||||||||
| worldNL@minPxcor <- minPxcor | ||||||||
| worldNL@maxPxcor <- maxPxcor | ||||||||
| worldNL@minPycor <- minPycor | ||||||||
| worldNL@maxPycor <- maxPycor | ||||||||
| worldNL@pxcor <- world@pxcor | ||||||||
| worldNL@pycor <- world@pycor | ||||||||
| return(worldNL) | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname convertNLworld | ||||||||
| setMethod( | ||||||||
| "convertNLworld", | ||||||||
| signature = c("RasterStack"), | ||||||||
| definition = function(raster) { | ||||||||
| worldStack <- new("NLworldStack") | ||||||||
| for(i in 1:nlayers(raster)){ | ||||||||
| world <- convertNLworld(raster = raster[[i]]) | ||||||||
| worldStack <- addLayer(worldStack, world) | ||||||||
| } | ||||||||
| return(worldStack) | ||||||||
| }) | ||||||||
| ################################################################################ | ||||||||
| #' Maximum pxcor | ||||||||
| #' | ||||||||
| #' Report the patches maximum pxcor in the \code{world}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Integer. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#max-pcor} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld() | ||||||||
| #' maxPxcor(w1) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname maxPxcor | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "maxPxcor", | ||||||||
| function(world) { | ||||||||
| standardGeneric("maxPxcor") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname maxPxcor | ||||||||
| setMethod( | ||||||||
| "maxPxcor", | ||||||||
| signature = "NLworld", | ||||||||
| definition = function(world) { | ||||||||
| return(world@maxPxcor) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname maxPxcor | ||||||||
| setMethod( | ||||||||
| "maxPxcor", | ||||||||
| signature = "NLworldStack", | ||||||||
| definition = function(world) { | ||||||||
| world_l <- world[[1]] | ||||||||
| maxPxcor(world = world_l) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Maximum pycor | ||||||||
| #' | ||||||||
| #' Report the patches maximum pycor in the \code{world}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Integer. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#max-pcor} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld() | ||||||||
| #' maxPycor(w1) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname maxPycor | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "maxPycor", | ||||||||
| function(world) { | ||||||||
| standardGeneric("maxPycor") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname maxPycor | ||||||||
| setMethod( | ||||||||
| "maxPycor", | ||||||||
| signature = "NLworld", | ||||||||
| definition = function(world) { | ||||||||
| return(world@maxPycor) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname maxPycor | ||||||||
| setMethod( | ||||||||
| "maxPycor", | ||||||||
| signature = "NLworldStack", | ||||||||
| definition = function(world) { | ||||||||
| world_l <- world[[1]] | ||||||||
| maxPycor(world = world_l) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Minimum pxcor | ||||||||
| #' | ||||||||
| #' Report the patches minimum pxcor in the \code{world}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Integer. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#min-pcor} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld() | ||||||||
| #' minPxcor(w1) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname minPxcor | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "minPxcor", | ||||||||
| function(world) { | ||||||||
| standardGeneric("minPxcor") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname minPxcor | ||||||||
| setMethod( | ||||||||
| "minPxcor", | ||||||||
| signature = "NLworld", | ||||||||
| definition = function(world) { | ||||||||
| return(world@minPxcor) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname minPxcor | ||||||||
| setMethod( | ||||||||
| "minPxcor", | ||||||||
| signature = "NLworldStack", | ||||||||
| definition = function(world) { | ||||||||
| world_l <- world[[1]] | ||||||||
| minPxcor(world = world_l) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Minimum pycor | ||||||||
| #' | ||||||||
| #' Report the patches minimum pycor in the \code{world}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Integer. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#min-pcor} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld() | ||||||||
| #' minPycor(w1) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname minPycor | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "minPycor", | ||||||||
| function(world) { | ||||||||
| standardGeneric("minPycor") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname minPycor | ||||||||
| setMethod( | ||||||||
| "minPycor", | ||||||||
| signature = "NLworld", | ||||||||
| definition = function(world) { | ||||||||
| return(world@minPycor) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname minPycor | ||||||||
| setMethod( | ||||||||
| "minPycor", | ||||||||
| signature = "NLworldStack", | ||||||||
| definition = function(world) { | ||||||||
| world_l <- world[[1]] | ||||||||
| minPycor(world = world_l) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' World width | ||||||||
| #' | ||||||||
| #' Report the width of the \code{world} in patch number. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Integer. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#world-dim} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld() | ||||||||
| #' worldWidth(w1) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname worldWidth | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "worldWidth", | ||||||||
| function(world) { | ||||||||
| standardGeneric("worldWidth") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname worldWidth | ||||||||
| setMethod( | ||||||||
| "worldWidth", | ||||||||
| signature = "NLworlds", | ||||||||
| definition = function(world) { | ||||||||
| w_width <- maxPxcor(world) - minPxcor(world) + 1 | ||||||||
| return(w_width) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' World height | ||||||||
| #' | ||||||||
| #' Report the height of the \code{world} in patch number. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Integer. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#world-dim} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld() | ||||||||
| #' worldHeight(w1) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname worldHeight | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "worldHeight", | ||||||||
| function(world) { | ||||||||
| standardGeneric("worldHeight") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname worldHeight | ||||||||
| setMethod( | ||||||||
| "worldHeight", | ||||||||
| signature = "NLworlds", | ||||||||
| definition = function(world) { | ||||||||
| w_height <- maxPycor(world) - minPycor(world) + 1 | ||||||||
| return(w_height) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Clear world's patches | ||||||||
| #' | ||||||||
| #' Reset all patches values to \code{NA}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return NLworld object with \code{NA} values for all patches. | ||||||||
| #' | ||||||||
| #' @details The name of the layer is set to \code{""}. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#clear-patches} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld() | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = runif(count(patches(w1)))) | ||||||||
| #' w1Val <- of(world = w1, agents = patches(w1)) | ||||||||
| #' summary(w1Val) | ||||||||
| #' | ||||||||
| #' w1 <- clearPatches(w1) | ||||||||
| #' w1Val <- of(world = w1, agents = patches(w1)) | ||||||||
| #' summary(w1Val) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname clearPatches | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "clearPatches", | ||||||||
| function(world) { | ||||||||
| standardGeneric("clearPatches") | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname clearPatches | ||||||||
| setMethod( | ||||||||
| "clearPatches", | ||||||||
| signature = c("NLworld"), | ||||||||
| definition = function(world) { | ||||||||
| worldNA <- setValues(world, NA) | ||||||||
| worldNA@data@names <- "" | ||||||||
| return(worldNA) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname clearPatches | ||||||||
| setMethod( | ||||||||
| "clearPatches", | ||||||||
| signature = c("NLworldStack"), | ||||||||
| definition = function(world) { | ||||||||
| world_l <- world[[1]] | ||||||||
| clearPatches(world = world_l) | ||||||||
| } | ||||||||
| ) | ||||||||
| C:\Eliot\GitHub\NetLogoR/R/patch-functions.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| ################################################################################ | ||||||||
| #' Diffuse values in a world | ||||||||
| #' | ||||||||
| #' Each patch gives an equal share of a portion of its value to its neighbor patches. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param share Numeric. Value between 0 and 1 representing the portion of | ||||||||
| #' the patches values to be diffused among the neighbors. | ||||||||
| #' | ||||||||
| #' @return NLworlds object with patches values updated. | ||||||||
| #' | ||||||||
| #' @details What is given is lost for the patches. | ||||||||
| #' | ||||||||
| #' If \code{torus = TRUE}, all patches have \code{nNeighbors} patches around them, which | ||||||||
| #' some may be on the other sides of the \code{world}. If \code{torus = FALSE}, | ||||||||
| #' patches located on the edges of the \code{world} have less than \code{nNeighbors} patches around them. | ||||||||
| #' However, each neighbor still gets 1/4 or 1/8 of the shared amount and the diffusing | ||||||||
| #' patch keeps the leftover. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#diffuse} | ||||||||
| #' | ||||||||
| #' \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#diffuse4} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 4, minPycor = 0, maxPycor = 4) | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = runif(count(patches(w1)))) | ||||||||
| #' plot(w1) | ||||||||
| #' # Diffuse 50% of each patch value to its 8 neighbors | ||||||||
| #' w2 <- diffuse(world = w1, share = 0.5, nNeighbors = 8) | ||||||||
| #' plot(w2) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @importFrom SpaDES adj | ||||||||
| #' @docType methods | ||||||||
| #' @rdname diffuse | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "diffuse", | ||||||||
| function(world, pVar, share, nNeighbors, torus = FALSE) { | ||||||||
| standardGeneric("diffuse") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname diffuse | ||||||||
| setMethod( | ||||||||
| "diffuse", | ||||||||
| signature = c(world = "NLworld", pVar = "missing", share = "numeric", nNeighbors = "numeric"), | ||||||||
| definition = function(world, share, nNeighbors, torus) { | ||||||||
| val <- values(world) | ||||||||
| cellNum <- 1:length(val) | ||||||||
| toGive <- (val * share) / nNeighbors | ||||||||
| df1 <- cbind.data.frame(cellNum, toGive) | ||||||||
| df2 <- as.data.frame(adj(world, cells = cellNum, directions = nNeighbors, torus = torus)) | ||||||||
| df3 <- merge(df2, df1, by.x = "from", by.y = "cellNum", all = TRUE) | ||||||||
| loose <- tapply(df3$toGive, FUN = sum, INDEX = df3$from) # how much each patch give | ||||||||
| win <- tapply(df3$toGive, FUN = sum, INDEX = df3$to) # how much each patch receive | ||||||||
| newVal <- val - loose + win | ||||||||
| newWorld <- setValues(world, as.numeric(newVal)) | ||||||||
| return(newWorld) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname diffuse | ||||||||
| setMethod( | ||||||||
| "diffuse", | ||||||||
| signature = c(world = "NLworldStack", pVar = "character", share = "numeric", nNeighbors = "numeric"), | ||||||||
| definition = function(world, pVar, share, nNeighbors, torus) { | ||||||||
| pos_l <- which(names(world) == pVar, TRUE) # find the layer | ||||||||
| world_l <- world[[pos_l]] | ||||||||
| newWorld <- diffuse(world = world_l, share = share, nNeighbors = nNeighbors, torus = torus) | ||||||||
| world[[pos_l]]@data@values <- values(newWorld) | ||||||||
| return(world) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Distances between agents | ||||||||
| #' | ||||||||
| #' Report the distances between \code{agents} and \code{agents2}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param allPairs Logical. Only relevant if the number of agents/locations in | ||||||||
| #' \code{agents} and in \code{agents2} are the same. If \code{allPairs = FALSE}, | ||||||||
| #' the distance between each \code{agents} with the | ||||||||
| #' corresponding \code{agents2} is returned. If \code{allPairs = TRUE}, a full | ||||||||
| #' distance matrix is returned. Default is \code{allPairs = FALSE}. | ||||||||
| #' | ||||||||
| #' @return Numeric. Vector of distances between \code{agents} and \code{agents2} if | ||||||||
| #' \code{agents} and/or \code{agents2} contained | ||||||||
| #' one agent/location, or if \code{agents} and \code{agents2} contained the same | ||||||||
| #' number of agents/locations and \code{allPairs = FALSE}, or | ||||||||
| #' | ||||||||
| #' Matrix of distances between \code{agents} (rows) and \code{agents2} (columns) | ||||||||
| #' if \code{agents} and \code{agents2} are of different lengths, or of same length | ||||||||
| #' and \code{allPairs = TRUE}. | ||||||||
| #' | ||||||||
| #' @details Distances from/to a patch are measured from/to its center. | ||||||||
| #' | ||||||||
| #' If \code{torus = FALSE}, \code{world} does not need to be provided. | ||||||||
| #' | ||||||||
| #' If \code{torus = TRUE}, a distance around the sides of the \code{world} is | ||||||||
| #' reported only if smaller than the one across the \code{world} (i.e., as calculated | ||||||||
| #' with \code{torus = FALSE}). | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#distance} | ||||||||
| #' | ||||||||
| #' \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#distancexy} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' NLdist(agents = patch(w1, 0, 0), agents2 = patch(w1, c(1, 9), c(1, 9))) | ||||||||
| #' NLdist(agents = patch(w1, 0, 0), agents2 = patch(w1, c(1, 9), c(1, 9)), world = w1, torus = TRUE) | ||||||||
| #' t1 <- createTurtles(n = 2, coords = randomXYcor(w1, n = 2)) | ||||||||
| #' NLdist(agents = t1, agents2 = patch(w1, c(1,9), c(1,9)), allPairs = TRUE) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname NLdist | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "NLdist", | ||||||||
| function(agents, agents2, world, torus = FALSE, allPairs = FALSE) { | ||||||||
| standardGeneric("NLdist") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname NLdist | ||||||||
| setMethod( | ||||||||
| "NLdist", | ||||||||
| signature = c(agents = "matrix", agents2 = "matrix"), | ||||||||
| definition = function(agents, agents2, world, torus, allPairs) { | ||||||||
| dist <- pointDistance(p1 = agents, p2 = agents2, lonlat = FALSE, allpairs = allPairs) | ||||||||
| if(torus == TRUE){ | ||||||||
| if(missing(world)){ | ||||||||
| stop("A world must be provided as torus = TRUE") | ||||||||
| } | ||||||||
| # Need to create coordinates for "agents2" in a wrapped world | ||||||||
| # For all the 8 possibilities of wrapping (to the left, right, top, bottom and 4 corners) | ||||||||
| to1 <- cbind(pxcor = agents2[,1] - (world@extent@xmax - world@extent@xmin), pycor = agents2[,2] + (world@extent@ymax - world@extent@ymin)) | ||||||||
| to2 <- cbind(pxcor = agents2[,1], pycor = agents2[,2] + (world@extent@ymax - world@extent@ymin)) | ||||||||
| to3 <- cbind(pxcor = agents2[,1] + (world@extent@xmax - world@extent@xmin), pycor = agents2[,2] + (world@extent@ymax - world@extent@ymin)) | ||||||||
| to4 <- cbind(pxcor = agents2[,1] - (world@extent@xmax - world@extent@xmin), pycor = agents2[,2]) | ||||||||
| to5 <- cbind(pxcor = agents2[,1] + (world@extent@xmax - world@extent@xmin), pycor = agents2[,2]) | ||||||||
| to6 <- cbind(pxcor = agents2[,1] - (world@extent@xmax - world@extent@xmin), pycor = agents2[,2] - (world@extent@ymax - world@extent@ymin)) | ||||||||
| to7 <- cbind(pxcor = agents2[,1], pycor = agents2[,2] - (world@extent@ymax - world@extent@ymin)) | ||||||||
| to8 <- cbind(pxcor = agents2[,1] + (world@extent@xmax - world@extent@xmin), pycor = agents2[,2] - (world@extent@ymax - world@extent@ymin)) | ||||||||
| dist1 <- pointDistance(p1 = agents, p2 = to1, lonlat = FALSE, allpairs = allPairs) | ||||||||
| dist2 <- pointDistance(p1 = agents, p2 = to2, lonlat = FALSE, allpairs = allPairs) | ||||||||
| dist3 <- pointDistance(p1 = agents, p2 = to3, lonlat = FALSE, allpairs = allPairs) | ||||||||
| dist4 <- pointDistance(p1 = agents, p2 = to4, lonlat = FALSE, allpairs = allPairs) | ||||||||
| dist5 <- pointDistance(p1 = agents, p2 = to5, lonlat = FALSE, allpairs = allPairs) | ||||||||
| dist6 <- pointDistance(p1 = agents, p2 = to6, lonlat = FALSE, allpairs = allPairs) | ||||||||
| dist7 <- pointDistance(p1 = agents, p2 = to7, lonlat = FALSE, allpairs = allPairs) | ||||||||
| dist8 <- pointDistance(p1 = agents, p2 = to8, lonlat = FALSE, allpairs = allPairs) | ||||||||
| dist <- pmin(dist, dist1, dist2, dist3, dist4, dist5, dist6, dist7, dist8) | ||||||||
| } | ||||||||
| return(dist) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname NLdist | ||||||||
| setMethod( | ||||||||
| "NLdist", | ||||||||
| signature = c(agents = "matrix", agents2 = "SpatialPointsDataFrame"), | ||||||||
| definition = function(agents, agents2, world, torus, allPairs) { | ||||||||
| NLdist(world = world, agents = agents, agents2 = agents2@coords, torus = torus, allPairs = allPairs) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname NLdist | ||||||||
| setMethod( | ||||||||
| "NLdist", | ||||||||
| signature = c(agents = "SpatialPointsDataFrame", agents2 = "matrix"), | ||||||||
| definition = function(agents, agents2, world, torus, allPairs) { | ||||||||
| NLdist(world = world, agents = agents@coords, agents2 = agents2, torus = torus, allPairs = allPairs) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname NLdist | ||||||||
| setMethod( | ||||||||
| "NLdist", | ||||||||
| signature = c(agents = "SpatialPointsDataFrame", agents2 = "SpatialPointsDataFrame"), | ||||||||
| definition = function(agents, agents2, world, torus, allPairs) { | ||||||||
| NLdist(world = world, agents = agents@coords, agents2 = agents2@coords, torus = torus, allPairs = allPairs) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Do the patches exist? | ||||||||
| #' | ||||||||
| #' Report \code{TRUE} if a patch exists inside the \code{world}'s extent, report | ||||||||
| #' \code{FALSE} otherwise. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Logical. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#member} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' pExist(world = w1, pxcor = -1, pycor = 2) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname pExist | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "pExist", | ||||||||
| function(world, pxcor, pycor) { | ||||||||
| standardGeneric("pExist") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname pExist | ||||||||
| setMethod( | ||||||||
| "pExist", | ||||||||
| signature = c("NLworlds", "numeric", "numeric"), | ||||||||
| definition = function(world, pxcor, pycor) { | ||||||||
| if(length(pxcor) == 1 & length(pycor) != 1){ | ||||||||
| pxcor <- rep(pxcor, length(pycor)) | ||||||||
| } | ||||||||
| if(length(pycor) == 1 & length(pxcor) != 1){ | ||||||||
| pycor <- rep(pycor, length(pxcor)) | ||||||||
| } | ||||||||
| pxmin <- minPxcor(world) | ||||||||
| pxmax <- maxPxcor(world) | ||||||||
| pymin <- minPycor(world) | ||||||||
| pymax <- maxPycor(world) | ||||||||
| pxcorIn <- pxcor >= pxmin & pxcor <= pxmax | ||||||||
| pycorIn <- pycor >= pymin & pycor <= pymax | ||||||||
| pExist <- pxcorIn & pycorIn | ||||||||
| return(pExist) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Neighbors patches | ||||||||
| #' | ||||||||
| #' Report the coordinates of the neighbors patches around the \code{agents}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 3) with the first column "pxcor" | ||||||||
| #' and the second column "pycor" representing the coordinates of the neighbors | ||||||||
| #' patches around the \code{agents} and the third column "id" representing | ||||||||
| #' the \code{agents}. | ||||||||
| #' | ||||||||
| #' @details The patch around which the neighbors are identified, or the patch where | ||||||||
| #' the turtle is located on around which the neighbors are identified, is not | ||||||||
| #' returned. | ||||||||
| #' | ||||||||
| #' If \code{torus = FALSE}, \code{agents} located on the edges of the \code{world} | ||||||||
| #' have less than \code{nNeighbors} patches around them. If \code{torus = TRUE}, all \code{agents} | ||||||||
| #' located on the egdes of the \code{world} have \code{nNeighbors} patches around them, which | ||||||||
| #' some may be on the other sides of the \code{world}. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#neighbors} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' neighbors(world = w1, agents = patch(w1, c(0,9), c(0,7)), nNeighbors = 8) | ||||||||
| #' t1 <- createTurtles(n = 3, coords = randomXYcor(w1, n = 3)) | ||||||||
| #' neighbors(world = w1, agents = t1, nNeighbors = 4) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @importFrom SpaDES adj adj.raw | ||||||||
| #' @importFrom data.table data.table setkey | ||||||||
| #' @docType methods | ||||||||
| #' @rdname neighbors | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "neighbors", | ||||||||
| function(world, agents, nNeighbors, torus = FALSE) { | ||||||||
| standardGeneric("neighbors") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname neighbors | ||||||||
| setMethod( | ||||||||
| "neighbors", | ||||||||
| signature = c(world = "NLworlds", agents = "matrix", nNeighbors = "numeric"), | ||||||||
| definition = function(world, agents, nNeighbors, torus) { | ||||||||
| if (NROW(agents)<1e2) { # data.frame is faster below 100 agents, data.table faster above | ||||||||
| cellNum <- cellFromPxcorPycor(world = world, pxcor = agents[,1], pycor = agents[,2]) | ||||||||
| neighbors <- adj.raw(world, cells = cellNum, directions = nNeighbors, | ||||||||
| torus = torus, id=seq_along(cellNum)) | ||||||||
| pCoords <- PxcorPycorFromCell(world = world, cellNum = neighbors[,2]) | ||||||||
| neighbors_df <- data.frame(neighbors, pCoords) | ||||||||
| # Output as a matrix | ||||||||
| neighbors_df <- neighbors_df[order(neighbors_df$id),] | ||||||||
| listAgents <- cbind(pxcor = neighbors_df$pxcor, pycor = neighbors_df$pycor, id = neighbors_df$id) | ||||||||
| } else { | ||||||||
| cellNum <- cellFromPxcorPycor(world = world, pxcor = agents[,1], pycor = agents[,2]) | ||||||||
| neighbors <- data.table(adj(world, cells = cellNum, directions = nNeighbors, | ||||||||
| torus = torus, id=seq_along(cellNum))) | ||||||||
| cellNum <- data.table(cellNum=cellNum, id=seq_along(cellNum)) | ||||||||
| pCoords <- PxcorPycorFromCell(world = world, cellNum = neighbors[,to]) | ||||||||
| neighbors[,`:=`(pxcor=pCoords[,1], pycor=pCoords[,2])] | ||||||||
| # neighbors <- unique(neighbors) | ||||||||
| #setnames(cellNum, "cellNum", "from") | ||||||||
| # setkey(cellNum, cellNum) | ||||||||
| # setkey(neighbors, from) | ||||||||
| # neighbors_dt <- cellNum[neighbors, allow.cartesian=TRUE] | ||||||||
| setkey(neighbors, id) | ||||||||
| listAgents <- cbind(pxcor = neighbors$pxcor, | ||||||||
| pycor = neighbors$pycor, | ||||||||
| id = neighbors$id)# %>% as.factor %>% as.numeric) | ||||||||
| } | ||||||||
| return(listAgents) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname neighbors | ||||||||
| setMethod( | ||||||||
| "neighbors", | ||||||||
| signature = c(world = "NLworlds", agents = "SpatialPointsDataFrame", nNeighbors = "numeric"), | ||||||||
| definition = function(world, agents, nNeighbors, torus) { | ||||||||
| pTurtles <- patch(world = world, x = agents@coords[,1], y = agents@coords[,2], duplicate = TRUE) | ||||||||
| neighbors(world = world, agents = pTurtles, nNeighbors = nNeighbors, torus = torus) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Patches coordinates | ||||||||
| #' | ||||||||
| #' Report the coordinates of the patches at the given \code{[x, y]} locations. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param x Numeric. Vector of x coordinates. Must be of same | ||||||||
| #' length as \code{y}. | ||||||||
| #' | ||||||||
| #' @param y Numeric. Vector of y coordinates. Must be of same | ||||||||
| #' length as \code{x}. | ||||||||
| #' | ||||||||
| #' @param duplicate Logical. If more than one location \code{[x, y]} | ||||||||
| #' fall into the same patch and \code{duplicate == TRUE}, the | ||||||||
| #' patch coordinates are returned the number of times the locations. | ||||||||
| #' If \code{duplicate == FALSE}, the patch coordinates | ||||||||
| #' are only returned once. | ||||||||
| #' Default is \code{duplicate == FALSE}. | ||||||||
| #' | ||||||||
| #' @param out Logical. If \code{out = FALSE}, no patch coordinates are returned | ||||||||
| #' for patches outside of the \code{world}'s extent, if \code{out = TRUE}, | ||||||||
| #' \code{NA} are returned. | ||||||||
| #' Default is \code{out = FALSE}. | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2) with the first column "pxcor" and the second column | ||||||||
| #' "pycor" representing the patches coordinates at \code{[x, y]}. | ||||||||
| #' | ||||||||
| #' @details If a location \code{[x, y]} is outside the \code{world}'s extent and | ||||||||
| #' \code{torus = FALSE} and \code{out = FALSE}, no patch coordinates are returned; | ||||||||
| #' if \code{torus = FALSE} and \code{out = TRUE}, \code{NA} are returned; | ||||||||
| #' if \code{torus = TRUE}, the patch coordinates from a wrapped \code{world} are | ||||||||
| #' returned. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#patch} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' patch(world = w1, x = c(0, 9.1, 8.9, 5, 5.3), y = c(0, 0, -0.1, 12.4, 12.4)) | ||||||||
| #' patch(world = w1, x = c(0, 9.1, 8.9, 5, 5.3), y = c(0, 0, -0.1, 12.4, 12.4), duplicate = TRUE) | ||||||||
| #' patch(world = w1, x = c(0, 9.1, 8.9, 5, 5.3), y = c(0, 0, -0.1, 12.4, 12.4), torus = TRUE) | ||||||||
| #' patch(world = w1, x = c(0, 9.1, 8.9, 5, 5.3), y = c(0, 0, -0.1, 12.4, 12.4), torus = TRUE, duplicate = TRUE) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @importFrom SpaDES wrap | ||||||||
| #' @docType methods | ||||||||
| #' @rdname patch | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "patch", | ||||||||
| function(world, x, y, duplicate = FALSE, torus = FALSE, out = FALSE) { | ||||||||
| standardGeneric("patch") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname patch | ||||||||
| setMethod( | ||||||||
| "patch", | ||||||||
| signature = c(world = "NLworlds", x = "numeric", y = "numeric"), | ||||||||
| definition = function(world, x, y, duplicate, torus, out) { | ||||||||
| pxcor_ <- round(x) | ||||||||
| pycor_ <- round(y) | ||||||||
| if(torus == TRUE){ | ||||||||
| pCoords <- wrap(cbind(x = pxcor_, y = pycor_), extent(world)) | ||||||||
| pxcor_ <- pCoords[,1] | ||||||||
| pycor_ <- pCoords[,2] | ||||||||
| } | ||||||||
| pxcorNA <- ifelse(pxcor_ < minPxcor(world) | pxcor_ > maxPxcor(world), NA, pxcor_) | ||||||||
| pycorNA <- ifelse(pycor_ < minPycor(world) | pycor_ > maxPycor(world), NA, pycor_) | ||||||||
| pxcorNA[is.na(pycorNA)] <- NA | ||||||||
| pycorNA[is.na(pxcorNA)] <- NA | ||||||||
| if(out == FALSE){ | ||||||||
| pxcor = pxcorNA[!is.na(pxcorNA)] | ||||||||
| pycor = pycorNA[!is.na(pycorNA)] | ||||||||
| } else { | ||||||||
| pxcor = pxcorNA | ||||||||
| pycor = pycorNA | ||||||||
| } | ||||||||
| pCoords <- matrix(data = cbind(pxcor, pycor), ncol = 2, nrow = length(pxcor), dimnames = list(NULL, c("pxcor", "pycor"))) | ||||||||
| if(duplicate == FALSE){ | ||||||||
| pCoords <- unique(pCoords) | ||||||||
| } | ||||||||
| return(pCoords) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' No patches | ||||||||
| #' | ||||||||
| #' Report an empty patch agentset. | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2, nrow = 0) with the first column "pxcor" and the | ||||||||
| #' second column "pycor". | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#no-patches} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' p1 <- noPatches() | ||||||||
| #' count(p1) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname noPatches | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "noPatches", | ||||||||
| function(x) { | ||||||||
| standardGeneric("noPatches") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname noPatches | ||||||||
| setMethod( | ||||||||
| "noPatches", | ||||||||
| signature = "missing", | ||||||||
| definition = function() { | ||||||||
| return(matrix(, nrow = 0, ncol = 2, dimnames = list(NULL, c("pxcor", "pycor")))) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Patches at | ||||||||
| #' | ||||||||
| #' Report the coordinates of the patches at \code{(dx, dy)} distances of the \code{agents}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2) with the first column "pxcor" and the second column | ||||||||
| #' "pycor" representing the coordinates of the patches at \code{(dx, dy)} | ||||||||
| #' distances of the \code{agents}. The order of the patches follows the order | ||||||||
| #' of the \code{agents}. | ||||||||
| #' | ||||||||
| #' @details If the patch at distance \code{(dx, dy)} | ||||||||
| #' of an agent is outside of the \code{world}'s extent and \code{torus = FALSE}, #code{NA} are returned | ||||||||
| #' for the patch coordinates; | ||||||||
| #' if \code{torus = TRUE}, the patch coordinates from a wrapped \code{world} are | ||||||||
| #' returned. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#patch-at} | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#at-points} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' patchCorner <- patchAt(world = w1, agents = patch(w1, 0, 0), dx = 1, dy = 1) | ||||||||
| #' t1 <- createTurtles(n = 1, coords = cbind(xcor = 0, ycor = 0)) | ||||||||
| #' patchCorner <- patchAt(world = w1, agents = t1, dx = 1, dy = 1) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname patchAt | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "patchAt", | ||||||||
| function(world, agents, dx, dy, torus = FALSE) { | ||||||||
| standardGeneric("patchAt") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname patchAt | ||||||||
| setMethod( | ||||||||
| "patchAt", | ||||||||
| signature = c(world = "NLworlds", agents = "matrix", dx = "numeric", dy = "numeric"), | ||||||||
| definition = function(world, agents, dx, dy, torus) { | ||||||||
| pxcor <- agents[,1] + dx | ||||||||
| pycor <- agents[,2] + dy | ||||||||
| pAt <- patch(world = world, x = pxcor, y = pycor, duplicate = TRUE, torus = torus, out = TRUE) | ||||||||
| return(pAt) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname patchAt | ||||||||
| setMethod( | ||||||||
| "patchAt", | ||||||||
| signature = c(world = "NLworlds", agents = "SpatialPointsDataFrame", dx = "numeric", dy = "numeric"), | ||||||||
| definition = function(world, agents, dx, dy, torus) { | ||||||||
| patchAt(world = world, agents = agents@coords, dx = dx, dy = dy, torus = torus) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Patches at certain distances and certain directions | ||||||||
| #' | ||||||||
| #' Report the coordinates of the patches at the given | ||||||||
| #' distances and directions from the \code{agents}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param dist Numeric. Vector of distances from the \code{agents}. Must be | ||||||||
| #' of length 1 or of the same length as the number of \code{agents}. | ||||||||
| #' | ||||||||
| #' @param angle Numeric. Absolute directions from the \code{agents}. \code{angle} | ||||||||
| #' must be of length 1 or of the same length as the number of | ||||||||
| #' \code{agents}. Angles are in degrees with 0 being North. | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2) with the first column "pxcor" and the second column | ||||||||
| #' "pycor" representing the coordinates of the patches at the distances \code{dist} | ||||||||
| #' and directions \code{angle} | ||||||||
| #' of \code{agents}. The order of the patches follows the order of the \code{agents}. | ||||||||
| #' | ||||||||
| #' @details If \code{torus = FALSE} and the patch at distance \code{dist} and | ||||||||
| #' direction \code{angle} of an agent is outside the \code{world}'s extent, \code{NA} | ||||||||
| #' are returned for the patch coordinates. If \code{torus = TRUE}, the patch | ||||||||
| #' coordinates from a wrapped \code{world} are returned. | ||||||||
| #' | ||||||||
| #' If \code{agents} are turtles, their headings are not taken into account; the | ||||||||
| #' given directions \code{angle} are used. To find a patch at certain | ||||||||
| #' distance from a turtle using the turtle's heading, look at \code{pacthAhead()}, | ||||||||
| #' \code{patchLeft()} or \code{patchRight()}. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#patch-at-heading-and-distance} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' p1 <- patchDistDir(world = w1, agents = patch(w1, 0, 0), dist = 1, angle = 45) | ||||||||
| #' t1 <- createTurtles(n = 1, coords = cbind(xcor = 0, ycor = 0), heading = 315) | ||||||||
| #' p2 <- patchDistDir(world = w1, agents = t1, dist = 1, angle = 45) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @importFrom CircStats rad | ||||||||
| #' @docType methods | ||||||||
| #' @rdname patchDistDir | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "patchDistDir", | ||||||||
| function(world, agents, dist, angle, torus = FALSE) { | ||||||||
| standardGeneric("patchDistDir") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname patchDistDir | ||||||||
| setMethod( | ||||||||
| "patchDistDir", | ||||||||
| signature = c(world = "NLworlds", agents = "matrix", dist = "numeric", angle = "numeric"), | ||||||||
| definition = function(world, agents, dist, angle, torus) { | ||||||||
| pxcor <- agents[,1] + sin(rad(angle)) * dist | ||||||||
| pycor <- agents[,2] + cos(rad(angle)) * dist | ||||||||
| pDistHead <- patch(world = world, x = pxcor, y = pycor, torus = torus, duplicate = TRUE, out = TRUE) | ||||||||
| return(pDistHead) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname patchDistDir | ||||||||
| setMethod( | ||||||||
| "patchDistDir", | ||||||||
| signature = c(world = "NLworlds", agents = "SpatialPointsDataFrame", dist = "numeric", angle = "numeric"), | ||||||||
| definition = function(world, agents, dist, angle, torus) { | ||||||||
| patchDistDir(world = world, agents = agents@coords, dist = dist, angle = angle, torus = torus) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' All the patches in a world | ||||||||
| #' | ||||||||
| #' Report the coordinates of all the patches in the \code{world}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2) with the first column "pxcor" and the second column | ||||||||
| #' "pycor" representing the patches coordinates. The order of the patches | ||||||||
| #' follows the order of the cells numbers as defined for a \code{Raster*}. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#patches} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) # 100 patches | ||||||||
| #' allPatches <- patches(world = w1) | ||||||||
| #' count(allPatches) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname patches | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "patches", | ||||||||
| function(world) { | ||||||||
| standardGeneric("patches") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname patches | ||||||||
| setMethod( | ||||||||
| "patches", | ||||||||
| signature = "NLworld", | ||||||||
| definition = function(world) { | ||||||||
| return(cbind(pxcor = world@pxcor, pycor = world@pycor)) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @rdname patches | ||||||||
| setMethod( | ||||||||
| "patches", | ||||||||
| signature = "NLworldStack", | ||||||||
| definition = function(world) { | ||||||||
| world_l <- world[[1]] | ||||||||
| patches(world = world_l) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Patch set | ||||||||
| #' | ||||||||
| #' Report a patch agentset as the coordinates of all the patches contained in the inputs. | ||||||||
| #' | ||||||||
| #' @param ... Matrices (ncol = 2) of patches coordinates with the first column | ||||||||
| #' "pxcor" and the second column "pycor". | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2) with the first column "pxcor" and the second column | ||||||||
| #' "pycor" representing the patches coordinates. | ||||||||
| #' | ||||||||
| #' @details Duplicate patches among the inputs are removed in the returned matrix. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#patch-set} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' p1 <- patchAt(world = w1, agents = patch(w1, c(0,1,2), c(0,0,0)), dx = 1, dy = 1) | ||||||||
| #' p2 <- patchDistDir(world = w1, agents = patch(w1, 0, 0), dist = 1, angle = 45) | ||||||||
| #' p3 <- patch(world = w1, x = 4.3, y = 8) | ||||||||
| #' p4 <- patchSet(p1, p2, p3) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname patchSet | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "patchSet", | ||||||||
| function(...) { | ||||||||
| standardGeneric("patchSet") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname patchSet | ||||||||
| setMethod( | ||||||||
| "patchSet", | ||||||||
| signature = "matrix", | ||||||||
| definition = function(...) { | ||||||||
| dots <-list(...) | ||||||||
| pCoords <- unique(do.call(rbind, dots)) | ||||||||
| return(pCoords) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Random pxcor | ||||||||
| #' | ||||||||
| #' Report \code{n} random pxcor coordinates within the \code{world}'s extent. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Integer. Vector of length \code{n} of pxcor coordinates. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-pcor} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' pxcor <- randomPxcor(world = w1, n = 10) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname randomPxcor | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "randomPxcor", | ||||||||
| function(world, n) { | ||||||||
| standardGeneric("randomPxcor") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname randomPxcor | ||||||||
| setMethod( | ||||||||
| "randomPxcor", | ||||||||
| signature = c("NLworlds", "numeric"), | ||||||||
| definition = function(world, n) { | ||||||||
| minPxcor <- minPxcor(world) | ||||||||
| maxPxcor <- maxPxcor(world) | ||||||||
| pxcor <- sample(minPxcor:maxPxcor, size = n, replace = TRUE) | ||||||||
| return(pxcor) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Random pycor | ||||||||
| #' | ||||||||
| #' Report \code{n} random pycor coordinates within the \code{world}'s extent. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Integer. Vector of length \code{n} of pycor coordinates. | ||||||||
| #' | ||||||||
| #' @seealso \url{https://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-pcor} | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' pycor <- randomPycor(world = w1, n = 10) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname randomPycor | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "randomPycor", | ||||||||
| function(world, n) { | ||||||||
| standardGeneric("randomPycor") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname randomPycor | ||||||||
| setMethod( | ||||||||
| "randomPycor", | ||||||||
| signature = c("NLworlds", "numeric"), | ||||||||
| definition = function(world, n) { | ||||||||
| minPycor <- minPycor(world) | ||||||||
| maxPycor <- maxPycor(world) | ||||||||
| pycor <- sample(minPycor:maxPycor, size = n, replace = TRUE) | ||||||||
| return(pycor) | ||||||||
| } | ||||||||
| ) | ||||||||
| C:\Eliot\GitHub\NetLogoR/R/NLworlds-class.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| ################################################################################ | ||||||||
| #' The NLworld class | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' A \code{NLworld} object is a grid composed of squared patches (i.e., pixels) | ||||||||
| #' that behaves mostly the same as a \code{RasterLayer} object. | ||||||||
| #' Patches have two coordinates \code{pxcor} and \code{pycor}, representing the | ||||||||
| #' location of their center. \code{pxcor} and \code{pycor} are always integer | ||||||||
| #' and increment by 1. \code{pxcor} increases as you move right and \code{pycor} | ||||||||
| #' increases as you move up. \code{pxcor} and \code{pycor} can be negative if | ||||||||
| #' there are patches to the left or below the patch \code{[pxcor = 0, pycor = 0]}. | ||||||||
| #' | ||||||||
| #' When creating a \code{NLworld} object, its extent is equal to \code{xmin = minPxcor - 0.5}, | ||||||||
| #' \code{xmax = maxPxcor + 0.5}, \code{ymin = minPycor - 0.5}, and \code{ymax = maxPycor + 0.5}. | ||||||||
| #' The number of patches created is then equal to | ||||||||
| #' \code{((maxPxcor - minPxcor) + 1) * ((maxPycor - minPycor) + 1)}. | ||||||||
| #' | ||||||||
| #' \code{[]} can be used to extract values from a \code{NLworld} object by using | ||||||||
| #' the patch coordinates \code{[pxcor, pyxor]}. When multiple coordinates are provided, | ||||||||
| #' the order of the values returned matches the order of the cell numbers as defined | ||||||||
| #' for a \code{RasterLayer}. \code{[] <-} can be used to replace patch values in a | ||||||||
| #' \code{NLworld} object. Similarly, when replacing values of several patches, the | ||||||||
| #' values should be given in the order of the cells numbers as defined for a \code{RasterLayer}. | ||||||||
| #' | ||||||||
| #' @inheritParams raster::RasterLayer | ||||||||
| #' | ||||||||
| #' @references Wilensky, U. 1999. NetLogo. http://ccl.northwestern.edu/netlogo/. | ||||||||
| #' Center for Connected Learning and Computer-Based Modeling, | ||||||||
| #' Northwestern University. Evanston, IL. | ||||||||
| #' | ||||||||
| #' @aliases NLworld | ||||||||
| #' @name NLworld-class | ||||||||
| #' @rdname NLworld-class | ||||||||
| #' @author Sarah Bauduin, Eliot McIntire, and Alex Chubaty | ||||||||
| #' @exportClass NLworld | ||||||||
| #' | ||||||||
| setClass( | ||||||||
| "NLworld", | ||||||||
| contains = c("RasterLayer"), | ||||||||
| representation ( | ||||||||
| minPxcor = "numeric", | ||||||||
| maxPxcor = "numeric", | ||||||||
| minPycor = "numeric", | ||||||||
| maxPycor = "numeric", | ||||||||
| pxcor = "numeric", | ||||||||
| pycor = "numeric" | ||||||||
| ) | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @name [ | ||||||||
| #' @docType methods | ||||||||
| #' @rdname NLworld-class | ||||||||
| setMethod( | ||||||||
| "[", | ||||||||
| signature("NLworld", "numeric", "numeric", "ANY"), | ||||||||
| definition = function(x, i, j, drop) { | ||||||||
| cells <- which(x@pxcor %in% i & x@pycor %in% j, TRUE) # cell number(s) | ||||||||
| xValues <- values(x) | ||||||||
| cellValues <- xValues[cells] | ||||||||
| return(cellValues) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @name [<- | ||||||||
| #' @rdname NLworld-class | ||||||||
| setReplaceMethod( | ||||||||
| "[", | ||||||||
| signature("NLworld","numeric","numeric","numeric"), | ||||||||
| definition = function(x, i, j, value) { | ||||||||
| cells <- which(x@pxcor %in% i & x@pycor %in% j, TRUE) # cell number(s) | ||||||||
| x@data@values[cells] <- value | ||||||||
| validObject(x) | ||||||||
| return(x) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' The NLworldStack class | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' A \code{NLworldStack} object is similar to a \code{RasterStack} object, it is | ||||||||
| #' a collection of \code{NLworld} objects with the same extent. | ||||||||
| #' | ||||||||
| #' @inheritParams raster::RasterStack | ||||||||
| #' | ||||||||
| #' @aliases NLworldStack | ||||||||
| #' @name NLworldStack-class | ||||||||
| #' @rdname NLworldStack-class | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' @exportClass NLworldStack | ||||||||
| #' | ||||||||
| setClass( | ||||||||
| "NLworldStack", | ||||||||
| contains = "RasterStack" | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @name [ | ||||||||
| #' @docType methods | ||||||||
| #' @rdname NLworldStack-class | ||||||||
| setMethod( | ||||||||
| "[", | ||||||||
| signature("NLworldStack", "numeric", "numeric", "ANY"), | ||||||||
| definition = function(x, i, j, drop) { | ||||||||
| x_l <- x[[1]] | ||||||||
| cells <- which(x_l@pxcor %in% i & x_l@pycor %in% j, TRUE) # same cell number(s) for all layers | ||||||||
| xValues <- values(x) | ||||||||
| cellValues <- xValues[cells,] | ||||||||
| if(class(cellValues) != "matrix"){ | ||||||||
| cellValues <- matrix(cellValues, ncol = nlayers(x), byrow = TRUE, dimnames = list(NULL, names(cellValues))) | ||||||||
| } | ||||||||
| return(cellValues) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @name [<- | ||||||||
| #' @rdname NLworldStack-class | ||||||||
| setReplaceMethod( | ||||||||
| "[", | ||||||||
| signature("NLworldStack","numeric","numeric","matrix"), | ||||||||
| definition = function(x, i, j, value) { | ||||||||
| x_l <- x[[1]] | ||||||||
| cells <- which(x_l@pxcor %in% i & x_l@pycor %in% j, TRUE) # same cell number(s) for all layers | ||||||||
| xValues <- values(x) | ||||||||
| xValues[cells,] <- value | ||||||||
| for(k in 1:nlayers(x)){ | ||||||||
| x <- setValues(x, values = xValues[,k], layer = k) # replace values of each layer | ||||||||
| } | ||||||||
| validObject(x) | ||||||||
| return(x) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @export | ||||||||
| #' @name [<- | ||||||||
| #' @rdname NLworldStack-class | ||||||||
| setReplaceMethod( | ||||||||
| "[", | ||||||||
| signature("NLworldStack","numeric","numeric","numeric"), | ||||||||
| definition = function(x, i, j, value) { | ||||||||
| value <- matrix(data = value, nrow = 1, ncol = length(value)) | ||||||||
| # Copy/paste of above. Putting : | ||||||||
| # x[i,j] <- value | ||||||||
| # did not work | ||||||||
| x_l <- x[[1]] | ||||||||
| cells <- which(x_l@pxcor %in% i & x_l@pycor %in% j, TRUE) # same cell number(s) for all layers | ||||||||
| xValues <- values(x) | ||||||||
| xValues[cells,] <- value | ||||||||
| for(k in 1:nlayers(x)){ | ||||||||
| x <- setValues(x, values = xValues[,k], layer = k) # replace values of each layer | ||||||||
| } | ||||||||
| validObject(x) | ||||||||
| return(x) | ||||||||
| # end copy/paste from above | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' The \code{NLworlds} class | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' The \code{NLworlds} class is the union of the \code{NLworld} and \code{NLworldStack} | ||||||||
| #' classes. Mostly used for building function purposes. | ||||||||
| #' | ||||||||
| #' @slot members NLworld, NLworldStack | ||||||||
| #' | ||||||||
| #' @aliases NLworlds | ||||||||
| #' @name NLworlds-class | ||||||||
| #' @rdname NLworlds-class | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' @exportClass NLworlds | ||||||||
| setClassUnion(name="NLworlds", | ||||||||
| members=c("NLworld", "NLworldStack") | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Create a NLworldStack | ||||||||
| #' | ||||||||
| #' Stack multiple NLworld objects. | ||||||||
| #' | ||||||||
| #' @param ... NLworld objects. | ||||||||
| #' | ||||||||
| #' @return NLworldStack object with the NLworld stacked as layers. | ||||||||
| #' | ||||||||
| #' @details The NLworld objects must have the same extents and cannot be empty | ||||||||
| #' (i.e., the patches values must be different than \code{NA}). | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld() | ||||||||
| #' w1 <- set(world = w1, agents = patches(w1), val = runif(count(patches(w1)))) | ||||||||
| #' w2 <- createNLworld() | ||||||||
| #' w2 <- set(world = w2, agents = patches(w2), val = runif(count(patches(w2)))) | ||||||||
| #' w3 <- NLstack(w1, w2) | ||||||||
| #' | ||||||||
| #' library(SpaDES) | ||||||||
| #' clearPlot() | ||||||||
| #' Plot(w3) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @importFrom raster addLayer | ||||||||
| #' @importFrom SpaDES objectNames | ||||||||
| #' @docType methods | ||||||||
| #' @rdname NLstack | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "NLstack", | ||||||||
| signature = "...", | ||||||||
| function(...) { | ||||||||
| standardGeneric("NLstack") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname NLstack | ||||||||
| setMethod( | ||||||||
| "NLstack", | ||||||||
| signature = "NLworld", | ||||||||
| definition = function(...) { | ||||||||
| rasterS <- stack(...) | ||||||||
| layerNames <- objectNames("NLstack") # get object names | ||||||||
| names(rasterS) <- sapply(layerNames, function(x) x$objs) | ||||||||
| worldStack <- as(rasterS, "NLworldStack") | ||||||||
| return(worldStack) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Cells numbers from patches coordinates | ||||||||
| #' | ||||||||
| #' Report the cells numbers as defined for a Raster* object given the patches | ||||||||
| #' coordinates \code{pxcor} and \code{pycor}. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @return Numeric. Vector of cells number. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' cellFromPxcorPycor(world = w1, pxcor = 0, pycor = 9) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname cellFromPxcorPycor | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "cellFromPxcorPycor", | ||||||||
| function(world, pxcor, pycor) { | ||||||||
| standardGeneric("cellFromPxcorPycor") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname cellFromPxcorPycor | ||||||||
| setMethod( | ||||||||
| "cellFromPxcorPycor", | ||||||||
| signature = c("NLworlds", "numeric", "numeric"), | ||||||||
| definition = function(world, pxcor, pycor) { | ||||||||
| cellNum <- cellFromXY(world, cbind(x = pxcor, y = pycor)) | ||||||||
| return(cellNum) | ||||||||
| } | ||||||||
| ) | ||||||||
| ################################################################################ | ||||||||
| #' Patches coordinates from cells numbers | ||||||||
| #' | ||||||||
| #' Report the patches coordinates given the cells numbers as defined for a Raster* object. | ||||||||
| #' | ||||||||
| #' @inheritParams fargs | ||||||||
| #' | ||||||||
| #' @param cellNum Integer. Vector of cells number. | ||||||||
| #' | ||||||||
| #' @return Matrix (ncol = 2) with the first column "pxcor" and the second | ||||||||
| #' column "pycor" in the order of the given \code{cellNum}. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' w1 <- createNLworld(minPxcor = 0, maxPxcor = 9, minPycor = 0, maxPycor = 9) | ||||||||
| #' cellNum <- cellFromPxcorPycor(world = w1, pxcor = 0, pycor = 9) | ||||||||
| #' PxcorPycorFromCell(world = w1, cellNum = cellNum) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname PxcorPycorFromCell | ||||||||
| #' | ||||||||
| #' @author Sarah Bauduin | ||||||||
| #' | ||||||||
| setGeneric( | ||||||||
| "PxcorPycorFromCell", | ||||||||
| function(world, cellNum) { | ||||||||
| standardGeneric("PxcorPycorFromCell") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname PxcorPycorFromCell | ||||||||
| setMethod( | ||||||||
| "PxcorPycorFromCell", | ||||||||
| signature = c("NLworlds", "numeric"), | ||||||||
| definition = function(world, cellNum) { | ||||||||
| XY <- xyFromCell(world, cellNum) | ||||||||
| pCoords <- cbind(pxcor = XY[,1], pycor = XY[,2]) | ||||||||
| return(pCoords) | ||||||||
| } | ||||||||
| ) | ||||||||
| C:\Eliot\GitHub\SpaDES/R/neighbourhood.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| if (getRversion() >= "3.1.0") { | ||||||||
| utils::globalVariables(c("angles", "pixIDs", "x", "y", "rasterVal")) | ||||||||
| } | ||||||||
| ############################################################## | ||||||||
| #' Fast `adjacent` function, and Just In Time compiled version | ||||||||
| #' | ||||||||
| #' Faster function for determining the cells of the 4, 8 or bishop | ||||||||
| #' neighbours of the \code{cells}. This is a hybrid function that uses | ||||||||
| #' matrix for small numbers of loci (<1e4) and data.table for larger numbers of loci | ||||||||
| #' | ||||||||
| #' Between 4x (large number loci) to 200x (small number loci) speed gains over | ||||||||
| #' \code{adjacent} in raster package. There is some extra speed gain if | ||||||||
| #' \code{NumCol} and \code{NumCells} are passed rather than a raster. | ||||||||
| #' Efficiency gains come from: | ||||||||
| #' 1. use \code{data.table} internally | ||||||||
| #' - no need to remove NAs because wrapped or outside points are | ||||||||
| #' just removed directly with data.table | ||||||||
| #' - use data.table to sort and fast select (though not fastest possible) | ||||||||
| #' 2. don't make intermediate objects; just put calculation into return statement | ||||||||
| #' | ||||||||
| #' The steps used in the algorithm are: | ||||||||
| #' 1. Calculate indices of neighbouring cells | ||||||||
| #' 2. Remove "to" cells that are | ||||||||
| #' - <1 or >numCells (i.e., they are above or below raster), using a single modulo calculation | ||||||||
| #' - where the modulo of "to" cells is equal to 1 if "from" cells are 0 (wrapped right to left) | ||||||||
| #' - or where the modulo of the "to" cells is equal to 0 if "from" cells are 1 (wrapped left to right) | ||||||||
| #' | ||||||||
| #' @param x Raster* object for which adjacency will be calculated. | ||||||||
| #' | ||||||||
| #' @param cells vector of cell numbers for which adjacent cells should be found. Cell numbers start with 1 in the upper-left corner and increase from left to right and from top to bottom | ||||||||
| #' | ||||||||
| #' @param directions the number of directions in which cells should be connected: 4 (rook's case), 8 (queen's case), or 'bishop' to connect cells with one-cell diagonal moves. Or a neigborhood matrix (see Details) | ||||||||
| #' | ||||||||
| #' @param sort logical. Whether the outputs should be sorted or not, using Cell IDs of the | ||||||||
| #' from cells (and to cells, if \code{match.adjacent} is TRUE. | ||||||||
| #' | ||||||||
| #' @param pairs logical. If TRUE, a matrix of pairs of adjacent cells is returned. If FALSE, a vector of cells adjacent to cells is returned | ||||||||
| #' | ||||||||
| #' @param include logical. Should the focal cells be included in the result? | ||||||||
| #' | ||||||||
| #' @param target a vector of cells that can be spread to. This is the inverse of a mask. | ||||||||
| #' | ||||||||
| #' @param numCol numeric indicating number of columns in the raster. Using this with numCell is a bit faster execution time. | ||||||||
| #' | ||||||||
| #' @param numCell numeric indicating number of cells in the raster. Using this with numCol is a bit faster execution time. | ||||||||
| #' | ||||||||
| #' @param match.adjacent logical. Should the returned object be the same as the \code{adjacent} | ||||||||
| #' function in the raster package. | ||||||||
| #' @param cutoff.for.data.table numeric. Above this value, the function uses data.table which is | ||||||||
| #' faster with large numbers of cells. | ||||||||
| #' | ||||||||
| #' @param torus Logical. Should the spread event wrap around to the other side of the raster. | ||||||||
| #' Default is FALSE. | ||||||||
| #' | ||||||||
| #' @param id numeric If not NULL, then function will return "id" column. Default NULL. | ||||||||
| #' | ||||||||
| #' @return a matrix of one or two columns, from and to. | ||||||||
| #' | ||||||||
| #' @seealso \code{\link[raster]{adjacent}} | ||||||||
| #' | ||||||||
| #' @importFrom data.table data.table key setcolorder setkey ':=' | ||||||||
| #' @importFrom raster ncell ncol nrow | ||||||||
| #' @importFrom stats na.omit | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname adj | ||||||||
| #' | ||||||||
| #' @author Eliot McIntire | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' library(raster) | ||||||||
| #' a <- raster(extent(0, 1000, 0, 1000), res = 1) | ||||||||
| #' sam <- sample(1:length(a), 1e4) | ||||||||
| #' numCol <- ncol(a) | ||||||||
| #' numCell <- ncell(a) | ||||||||
| #' adj.new <- adj(numCol = numCol, numCell = numCell, cells = sam, directions = 8) | ||||||||
| #' adj.new <- adj(numCol = numCol, numCell = numCell, cells = sam, directions = 8, | ||||||||
| #' include = TRUE) | ||||||||
| #' if (interactive()) print(head(adj.new)) | ||||||||
| #' | ||||||||
| adj.raw <- function(x = NULL, cells, directions = 8, sort = FALSE, pairs = TRUE, | ||||||||
| include = FALSE, target = NULL, numCol = NULL, numCell = NULL, | ||||||||
| match.adjacent = FALSE, cutoff.for.data.table = 1e4, | ||||||||
| torus = FALSE, id = NULL) { | ||||||||
| to = NULL | ||||||||
| J = NULL | ||||||||
| if ((length(cells)<cutoff.for.data.table)) { | ||||||||
| if (is.null(numCol) | is.null(numCell)) { | ||||||||
| if (is.null(x)) stop("must provide either numCol & numCell or a x") | ||||||||
| numCol = as.integer(ncol(x)) | ||||||||
| numCell = as.integer(ncell(x)) | ||||||||
| } | ||||||||
| if (directions == 8) { | ||||||||
| # determine the indices of the 8 surrounding cells of the cells cells | ||||||||
| topl <- as.integer(cells-numCol-1) | ||||||||
| top <- as.integer(cells-numCol) | ||||||||
| topr <- as.integer(cells-numCol+1) | ||||||||
| lef <- as.integer(cells-1) | ||||||||
| rig <- as.integer(cells+1) | ||||||||
| botl <- as.integer(cells+numCol-1) | ||||||||
| bot <- as.integer(cells+numCol) | ||||||||
| botr <- as.integer(cells+numCol+1) | ||||||||
| if (match.adjacent){ | ||||||||
| if (include){ | ||||||||
| adj <- cbind(from = rep.int(cells,times = 9), | ||||||||
| to = c(as.integer(cells), topl, lef, botl, | ||||||||
| topr, rig, botr, top, bot)) | ||||||||
| if(!is.null(id)) adj <- cbind(adj, id = rep.int(id, times = 9)) | ||||||||
| } else { | ||||||||
| adj = cbind(from = rep.int(cells, times = 8), | ||||||||
| to = c(topl, lef, botl, topr, rig, botr, top, bot)) | ||||||||
| if(!is.null(id)) adj <- cbind(adj, id = rep.int(id, times = 8)) | ||||||||
| } | ||||||||
| } else { | ||||||||
| if (include){ | ||||||||
| adj = cbind(from = rep.int(cells, times = 9), | ||||||||
| to = c(topl, top, topr, lef, as.integer(cells), rig, botl, bot, botr)) | ||||||||
| if(!is.null(id)) adj <- cbind(adj, id = rep.int(id, times = 9)) | ||||||||
| }else{ | ||||||||
| adj = cbind(from = rep.int(cells, times = 8), | ||||||||
| to = c(topl, top, topr, lef, rig, botl, bot, botr)) | ||||||||
| if(!is.null(id)) adj <- cbind(adj, id = rep.int(id, times = 8)) | ||||||||
| } | ||||||||
| } | ||||||||
| } else if (directions == 4) { | ||||||||
| # determine the indices of the 4 surrounding cells of the cells cells | ||||||||
| top <- as.integer(cells-numCol) | ||||||||
| lef <- as.integer(cells-1) | ||||||||
| rig <- as.integer(cells+1) | ||||||||
| bot <- as.integer(cells+numCol) | ||||||||
| if (match.adjacent){ | ||||||||
| if (include) { | ||||||||
| adj <- cbind(from = rep.int(cells, times = 5), | ||||||||
| to = c(as.integer(cells), lef, rig, top, bot)) | ||||||||
| if(!is.null(id)) adj <- cbind(adj, id = rep.int(id, times = 5)) | ||||||||
| } else { | ||||||||
| adj <- cbind(from = rep.int(cells, times = 4), | ||||||||
| to = c(lef, rig, top, bot)) | ||||||||
| if(!is.null(id)) adj <- cbind(adj, id = rep.int(id, times = 4)) | ||||||||
| } | ||||||||
| } else { | ||||||||
| if (include) { | ||||||||
| adj <- cbind(from = rep.int(cells, times = 5), | ||||||||
| to = c(top, lef, as.integer(cells), rig, bot)) | ||||||||
| if(!is.null(id)) adj <- cbind(adj, id = rep.int(id, times = 5)) | ||||||||
| } else { | ||||||||
| adj <- cbind(from = rep.int(cells, times = 4), | ||||||||
| to = c(top, lef, rig, bot)) | ||||||||
| if(!is.null(id)) adj <- cbind(adj, id = rep.int(id, times = 4)) | ||||||||
| } | ||||||||
| } | ||||||||
| } else if (directions == "bishop") { | ||||||||
| topl <- as.integer(cells-numCol-1) | ||||||||
| topr <- as.integer(cells-numCol+1) | ||||||||
| botl <- as.integer(cells+numCol-1) | ||||||||
| botr <- as.integer(cells+numCol+1) | ||||||||
| if (match.adjacent) { | ||||||||
| if (include) { | ||||||||
| adj <- cbind(from = rep.int(cells, times = 5), | ||||||||
| to = c(as.integer(cells), topl, botl, topr, botr)) | ||||||||
| if(!is.null(id)) adj <- cbind(adj, id = rep.int(id, times = 5)) | ||||||||
| } else { | ||||||||
| adj <- cbind(from = rep.int(cells, times = 4), | ||||||||
| to = c(topl, botl, topr, botr)) | ||||||||
| if(!is.null(id)) adj <- cbind(adj, id = rep.int(id, times = 4)) | ||||||||
| } | ||||||||
| } else { | ||||||||
| if (include) { | ||||||||
| adj <- cbind(from = rep.int(cells, times = 5), | ||||||||
| to = c(topl, topr, as.integer(cells), botl, botr)) | ||||||||
| if(!is.null(id)) adj <- cbind(adj, id = rep.int(id, times = 5)) | ||||||||
| } else { | ||||||||
| adj <- cbind(from = rep.int(cells, times = 4), | ||||||||
| to = c(topl, topr, botl, botr)) | ||||||||
| if(!is.null(id)) adj <- cbind(adj, id = rep.int(id, times = 4)) | ||||||||
| } | ||||||||
| } | ||||||||
| } else { | ||||||||
| stop("directions must be 4 or 8 or \'bishop\'") | ||||||||
| } | ||||||||
| # Remove all cells that are not target cells, if target is a vector of cells | ||||||||
| if (!is.null(target)) { | ||||||||
| adj <- adj[na.omit(adj[, "to"] %in% target),] | ||||||||
| } | ||||||||
| if (sort){ | ||||||||
| if (match.adjacent) { | ||||||||
| adj <- adj[order(adj[, "from"], adj[, "to"]), ] | ||||||||
| } else { | ||||||||
| adj <- adj[order(adj[, "from"]),] | ||||||||
| } | ||||||||
| } | ||||||||
| # Remove the "from" column if pairs is FALSE | ||||||||
| # Good time savings if no intermediate object is created | ||||||||
| if (!torus) { | ||||||||
| if (pairs) { | ||||||||
| return(adj[ | ||||||||
| !((((adj[, "to"]-1)%%numCell + 1) != adj[, "to"]) | #top or bottom of raster | ||||||||
| ((adj[, "from"]%%numCol + adj[, "to"]%%numCol) == 1))# | #right & left edge cells, with neighbours wrapped | ||||||||
| ,, drop = FALSE]) | ||||||||
| } else { | ||||||||
| return(adj[ | ||||||||
| !((((adj[, "to"]-1)%%numCell + 1) != adj[, "to"]) | #top or bottom of raster | ||||||||
| ((adj[, "from"]%%numCol + adj[, "to"]%%numCol) == 1))# | #right & left edge cells, with neighbours wrapped | ||||||||
| , 2, drop = FALSE]) | ||||||||
| } | ||||||||
| } else { | ||||||||
| whLefRig <- (adj[, "from"]%%numCol+adj[, "to"]%%numCol) == 1 | ||||||||
| adj[whLefRig, "to"] <- adj[whLefRig, "to"]+numCol*(adj[whLefRig, "from"]-adj[whLefRig, "to"]) | ||||||||
| whBotTop <- ((adj[, "to"]-1)%%numCell+1) != adj[, "to"] | ||||||||
| adj[whBotTop, "to"] <- adj[whBotTop, "to"]+sign(adj[whBotTop, "from"]-adj[whBotTop, "to"])*numCell | ||||||||
| if (pairs) { | ||||||||
| return(adj) | ||||||||
| } else { | ||||||||
| return(adj[, 2, drop = FALSE]) | ||||||||
| } | ||||||||
| } | ||||||||
| } else { | ||||||||
| #### THIS IS FOR SITUATIONS WHERE length(cells) is > 1e4; using data.table | ||||||||
| if (is.null(numCol) | is.null(numCell)) { | ||||||||
| if (is.null(x)) stop("must provide either numCol & numCell or a x") | ||||||||
| numCol <- as.integer(ncol(x)) | ||||||||
| numCell <- as.integer(ncell(x)) | ||||||||
| } | ||||||||
| if (directions == 8) { | ||||||||
| # determine the indices of the 8 surrounding cells of the cells cells | ||||||||
| topl <- as.integer(cells-numCol-1) | ||||||||
| top <- as.integer(cells-numCol) | ||||||||
| topr <- as.integer(cells-numCol+1) | ||||||||
| lef <- as.integer(cells-1) | ||||||||
| rig <- as.integer(cells+1) | ||||||||
| botl <- as.integer(cells+numCol-1) | ||||||||
| bot <- as.integer(cells+numCol) | ||||||||
| botr <- as.integer(cells+numCol+1) | ||||||||
| if (match.adjacent) { | ||||||||
| if (include) { | ||||||||
| adj <- data.table(from = rep.int(cells, times = 9), | ||||||||
| to = c(as.integer(cells), topl, lef, botl, | ||||||||
| topr, rig, botr, top, bot)) | ||||||||
| if(!is.null(id)) adj[,id:=rep.int(id, times = 9)] | ||||||||
| } else { | ||||||||
| adj <- data.table(from = rep.int(cells, times = 8), | ||||||||
| to = c(topl, lef, botl, topr, rig, botr, top, bot)) | ||||||||
| if(!is.null(id)) adj[,id:=rep.int(id, times = 8)] | ||||||||
| } | ||||||||
| } else { | ||||||||
| if (include) { | ||||||||
| adj <- data.table(from = rep.int(cells, times = 9), | ||||||||
| to = c(topl, top, topr, lef, as.integer(cells), | ||||||||
| rig, botl, bot, botr), | ||||||||
| key = "from") | ||||||||
| if(!is.null(id)) adj[,id:=rep.int(id, times = 9)] | ||||||||
| } else { | ||||||||
| adj <- data.table(from = rep.int(cells, times = 8), | ||||||||
| to = c(topl, top, topr, lef, rig, botl, bot, botr), | ||||||||
| key = "from") | ||||||||
| if(!is.null(id)) adj[,id:=rep.int(id, times = 8)] | ||||||||
| } | ||||||||
| } | ||||||||
| } else if (directions == 4) { | ||||||||
| # determine the indices of the 4 surrounding cells of the cells cells | ||||||||
| top <- as.integer(cells-numCol) | ||||||||
| lef <- as.integer(cells-1) | ||||||||
| rig <- as.integer(cells+1) | ||||||||
| bot <- as.integer(cells+numCol) | ||||||||
| if (match.adjacent) { | ||||||||
| if (include) { | ||||||||
| adj <- data.table(from = rep.int(cells, times = 5), | ||||||||
| to = c(as.integer(cells), lef, rig, top, bot)) | ||||||||
| if(!is.null(id)) adj[,id:=rep.int(id, times = 5)] | ||||||||
| } else { | ||||||||
| adj <- data.table(from = rep.int(cells, times = 4), | ||||||||
| to = c(lef, rig, top, bot)) | ||||||||
| if(!is.null(id)) adj[,id:=rep.int(id, times = 4)] | ||||||||
| } | ||||||||
| } else { | ||||||||
| if (include) { | ||||||||
| adj <- data.table(from = rep.int(cells, times = 5), | ||||||||
| to = c(top, lef, as.integer(cells), rig, bot), | ||||||||
| key = "from") | ||||||||
| if(!is.null(id)) adj[,id:=rep.int(id, times = 5)] | ||||||||
| } else { | ||||||||
| adj <- data.table(from = rep.int(cells, times = 4), | ||||||||
| to = c(top, lef, rig, bot), | ||||||||
| key = "from") | ||||||||
| if(!is.null(id)) adj[,id:=rep.int(id, times = 4)] | ||||||||
| } | ||||||||
| } | ||||||||
| } else if (directions == "bishop") { | ||||||||
| topl <- as.integer(cells-numCol-1) | ||||||||
| topr <- as.integer(cells-numCol+1) | ||||||||
| botl <- as.integer(cells+numCol-1) | ||||||||
| botr <- as.integer(cells+numCol+1) | ||||||||
| if (match.adjacent) { | ||||||||
| if (include) { | ||||||||
| adj <- data.table(from = rep.int(cells, times = 5), | ||||||||
| to = c(as.integer(cells), topl, botl, topr, botr)) | ||||||||
| if(!is.null(id)) adj[,id:=rep.int(id, times = 5)] | ||||||||
| } else { | ||||||||
| adj <- data.table(from = rep.int(cells, times = 4), | ||||||||
| to = c(topl, botl, topr, botr)) | ||||||||
| if(!is.null(id)) adj[,id:=rep.int(id, times = 4)] | ||||||||
| } | ||||||||
| } else { | ||||||||
| if (include) { | ||||||||
| adj <- data.table(from = rep.int(cells, times = 5), | ||||||||
| to = c(topl, topr, as.integer(cells), botl, botr), | ||||||||
| key = "from") | ||||||||
| if(!is.null(id)) adj[,id:=rep.int(id, times = 5)] | ||||||||
| } else { | ||||||||
| adj <- data.table(from = rep.int(cells, times = 4), | ||||||||
| to = c(topl, topr, botl, botr), | ||||||||
| key = "from") | ||||||||
| if(!is.null(id)) adj[,id:=rep.int(id, times = 4)] | ||||||||
| } | ||||||||
| } | ||||||||
| } else { | ||||||||
| stop("directions must be 4 or 8 or \'bishop\'") | ||||||||
| } | ||||||||
| # Remove all cells that are not target cells, if target is a vector of cells | ||||||||
| if (!is.null(target)) { | ||||||||
| setkey(adj, to) | ||||||||
| adj <- adj[J(target)] | ||||||||
| setkey(adj, from) | ||||||||
| setcolorder(adj, c("from", "to")) | ||||||||
| } | ||||||||
| # Remove the "from" column if pairs is FALSE | ||||||||
| if (!pairs) { | ||||||||
| from <- as.integer(adj$from) | ||||||||
| adj[, from:=NULL] | ||||||||
| } | ||||||||
| if (!torus) { | ||||||||
| return(as.matrix(adj[ | ||||||||
| !((((to-1)%%numCell+1) != to) | #top or bottom of raster | ||||||||
| ((from%%numCol+to%%numCol) == 1))# | #right & left edge cells, with neighbours wrapped | ||||||||
| ])) | ||||||||
| } else { | ||||||||
| whLefRig <- (from%%numCol + adj[, to]%%numCol) == 1 | ||||||||
| adj[whLefRig, to:=to+numCol*(from[whLefRig]-to)] | ||||||||
| whBotTop <- ((adj[, to]-1)%%numCell+1) != adj[, to] | ||||||||
| adj[whBotTop, to:=to+as.integer(sign(from[whBotTop]-to)*numCell)] | ||||||||
| return(as.matrix(adj)) | ||||||||
| } | ||||||||
| } | ||||||||
| } | ||||||||
| #' @importFrom compiler cmpfun | ||||||||
| #' @docType methods | ||||||||
| #' @export | ||||||||
| #' @rdname adj | ||||||||
| adj <- compiler::cmpfun(adj.raw) | ||||||||
| ############################################################## | ||||||||
| #' Identify pixels in a circle around a SpatialPoints* object. | ||||||||
| #' | ||||||||
| #' identify the pixels and coordinates that are at | ||||||||
| #' a (set of) buffer distance(s) of the SpatialPoints* objects. This can be used | ||||||||
| #' for agents. | ||||||||
| #' | ||||||||
| #' @param spatialPoints SpatialPoints* object around which to make circles . | ||||||||
| #' | ||||||||
| #' @param radii vector of radii that has same length as spatialPoints | ||||||||
| #' | ||||||||
| #' @param raster Raster on which the circles are built. | ||||||||
| #' | ||||||||
| #' @param simplify logical. If TRUE, then all duplicate pixels are removed. This means | ||||||||
| #' that some x, y combinations will disappear | ||||||||
| #' | ||||||||
| #' @return A \code{data.table} with 5 columns, \code{ids}, \code{pixelIDs}, | ||||||||
| #' \code{rasterVal}, \code{x}, \code{y}. The \code{x} and \code{y} indicate the | ||||||||
| #' coordinates of each | ||||||||
| #' unique pixel of the circle around each individual. | ||||||||
| #' | ||||||||
| #' @import igraph | ||||||||
| #' @importFrom data.table data.table set setkey ':=' | ||||||||
| #' @importFrom sp coordinates | ||||||||
| #' @importFrom raster cellFromXY extract res | ||||||||
| #' @export | ||||||||
| #' @rdname cir | ||||||||
| #' | ||||||||
| #'@examples | ||||||||
| #' library(raster) | ||||||||
| #' library(sp) | ||||||||
| #' | ||||||||
| #' Ras <- raster(extent(0, 15, 0, 15), res = 1) | ||||||||
| #' Ras <- randomPolygons(Ras, numTypes = 4, speedup = 1, p = 0.3) | ||||||||
| #' N <- 2 | ||||||||
| #' caribou <- SpatialPoints(coords = cbind(x = stats::runif(N, xmin(Ras), xmax(Ras)), | ||||||||
| #' y = stats::runif(N, xmin(Ras), xmax(Ras)))) | ||||||||
| #' cirs <- cir(caribou, rep(3, length(caribou)), Ras, simplify = TRUE) | ||||||||
| #' cirsSP <- SpatialPoints(coords = cirs[, list(x, y)]) | ||||||||
| #' cirsRas <- raster(Ras) | ||||||||
| #' cirsRas[] <- 0 | ||||||||
| #' cirsRas[cirs[, pixIDs]] <- 1 | ||||||||
| #' Plot(Ras, new = TRUE) | ||||||||
| #' Plot(cirsRas, addTo = "Ras", cols = c("transparent", "#00000055")) | ||||||||
| #' Plot(caribou, addTo = "Ras") | ||||||||
| #' Plot(cirsSP, addTo = "Ras") | ||||||||
| #' | ||||||||
| cir <- function(spatialPoints, radii, raster, simplify = TRUE) { | ||||||||
| scaleRaster <- res(raster) | ||||||||
| # create an index sequence for the number of individuals | ||||||||
| seqNumInd <- seq_len(length(spatialPoints)) | ||||||||
| # n = optimum number of points to create the circle for a given individual; | ||||||||
| # gross estimation (checked that it seems to be enough so that pixels | ||||||||
| # extracted are almost always duplicated, which means there is small | ||||||||
| # chance that we missed some on the circle). | ||||||||
| n.angles <- ( ceiling((radii/scaleRaster)*2*pi) + 1 ) | ||||||||
| ### Eliot's code to replace the createCircle of the package PlotRegionHighlighter | ||||||||
| positions <- coordinates(spatialPoints) | ||||||||
| # create individual IDs for the number of points that will be done for their circle | ||||||||
| ids <- rep.int(seqNumInd, times = n.angles) | ||||||||
| # create vector of radius for the number of points that will be done for each individual circle | ||||||||
| rads <- rep.int(radii, times = n.angles) | ||||||||
| # extract the individuals' current positions | ||||||||
| xs <- rep.int(positions[, 1], times = n.angles) | ||||||||
| ys <- rep.int(positions[, 2], times = n.angles) | ||||||||
| # calculate the angle increment that each individual needs to do to complete a circle (2 pi) | ||||||||
| angle.inc <- rep.int(2*pi, length(n.angles)) / n.angles | ||||||||
| # repeat this angle increment the number of times it needs to be done to complete the circles | ||||||||
| angs <- rep.int(angle.inc, times = n.angles) | ||||||||
| DT <- data.table(ids, angs, xs, ys, rads) | ||||||||
| DT[, "angles":=cumsum(angs), by = "ids"] # adds new column `angles` to DT that is the cumsum of angs for each id | ||||||||
| DT[, "x":=cos(angles)*rads+xs] # adds new column `x` to DT that is the cos(angles)*rads+xs | ||||||||
| DT[, "y":=sin(angles)*rads+ys] # adds new column `y` to DT that is the cos(angles)*rads+ys | ||||||||
| set(DT, , j = "rads", NULL) | ||||||||
| set(DT, , j = "angles", NULL) | ||||||||
| set(DT, , j = "angs", NULL) | ||||||||
| set(DT, , j = "xs", NULL) | ||||||||
| set(DT, , j = "ys", NULL) | ||||||||
| # put the coordinates of the points on the circles from all individuals in the same matrix | ||||||||
| #coords.all.ind <- DT[, list(x, y, ids)] | ||||||||
| # extract the pixel IDs under the points | ||||||||
| DT[, pixIDs := cellFromXY(raster, DT[, list(x, y)])] | ||||||||
| DT[, rasterVal := extract(raster, pixIDs)] | ||||||||
| if (simplify) { | ||||||||
| setkey(DT, "pixIDs") | ||||||||
| DT <- unique(DT) %>% na.omit | ||||||||
| } | ||||||||
| # list of df with x and y coordinates of each unique pixel of the circle of each individual | ||||||||
| return(DT) | ||||||||
| } | ||||||||
| ############################################################################### | ||||||||
| #' Wrap coordinates or pixels in a torus-like fashion | ||||||||
| #' | ||||||||
| #' Generally for model development purposes. | ||||||||
| #' | ||||||||
| #' If \code{withHeading} used, then X must be a \code{SpatialPointsDataFrame} | ||||||||
| #' that contains two columns, x1 and y1, with the immediately previous agent | ||||||||
| #' locations. | ||||||||
| #' | ||||||||
| #' @param X A SpatialPoints* object, or matrix of coordinates | ||||||||
| #' | ||||||||
| #' @param bounds Either a Raster*, Extent, or bbox object defining bounds to wrap around | ||||||||
| #' | ||||||||
| #' @param withHeading logical. If TRUE, then the previous points must be wrapped also | ||||||||
| #' so that the subsequent heading calculation will work. Default FALSE. See details. | ||||||||
| #' | ||||||||
| #' @return Same class as X, but with coordinates updated to reflect the wrapping | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @docType methods | ||||||||
| #' @rdname wrap | ||||||||
| #' | ||||||||
| #' @author Eliot McIntire | ||||||||
| #' @examples | ||||||||
| #' library(raster) | ||||||||
| #' xrange <- yrange <- c(-50, 50) | ||||||||
| #' hab <- raster(extent(c(xrange, yrange))) | ||||||||
| #' hab[] <- 0 | ||||||||
| #' | ||||||||
| #' # initialize caribou agents | ||||||||
| #' N <- 10 | ||||||||
| #' | ||||||||
| #' # previous points | ||||||||
| #' x1 <- rep(0, N) | ||||||||
| #' y1 <- rep(0, N) | ||||||||
| #' # initial points | ||||||||
| #' starts <- cbind(x = stats::runif(N, xrange[1], xrange[2]), | ||||||||
| #' y = stats::runif(N, yrange[1], yrange[2])) | ||||||||
| #' | ||||||||
| #' # create the caribou agent object | ||||||||
| #' caribou <- SpatialPointsDataFrame(coords = starts, data = data.frame(x1, y1)) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' ln <- rlnorm(N, 1, 0.02) # log normal step length | ||||||||
| #' sd <- 30 # could be specified globally in params | ||||||||
| #' | ||||||||
| #' Plot(hab, zero.color = "white", new = TRUE, axes = "L") | ||||||||
| #' for(i in 1:10) { | ||||||||
| #' caribou <- SpaDES::crw(agent = caribou, | ||||||||
| #' extent = extent(hab), stepLength = ln, | ||||||||
| #' stddev = sd, lonlat = FALSE, torus = TRUE) | ||||||||
| #' Plot(caribou, addTo = "hab", axes = TRUE) | ||||||||
| #' } | ||||||||
| setGeneric("wrap", function(X, bounds, withHeading) { | ||||||||
| standardGeneric("wrap") | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname wrap | ||||||||
| setMethod( | ||||||||
| "wrap", | ||||||||
| signature(X = "matrix", bounds = "Extent", withHeading = "missing"), | ||||||||
| definition = function(X, bounds) { | ||||||||
| if (identical(colnames(X), c("x", "y"))) { | ||||||||
| return(cbind( | ||||||||
| x = (X[, "x"] - bounds@xmin) %% (bounds@xmax - bounds@xmin) + bounds@xmin, | ||||||||
| y = (X[, "y"] - bounds@ymin) %% (bounds@ymax - bounds@ymin) + bounds@ymin | ||||||||
| )) | ||||||||
| } else { | ||||||||
| stop("When X is a matrix, it must have 2 columns, x and y,", | ||||||||
| "as from say, coordinates(SpatialPointsObj)") | ||||||||
| } | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname wrap | ||||||||
| setMethod( | ||||||||
| "wrap", | ||||||||
| signature(X = "SpatialPoints", bounds = "ANY", withHeading = "missing"), | ||||||||
| definition = function(X, bounds) { | ||||||||
| X@coords <- wrap(X@coords, bounds = bounds) | ||||||||
| return(X) | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname wrap | ||||||||
| setMethod( | ||||||||
| "wrap", | ||||||||
| signature(X = "matrix", bounds = "Raster", withHeading = "missing"), | ||||||||
| definition = function(X, bounds) { | ||||||||
| X <- wrap(X, bounds = extent(bounds)) | ||||||||
| return(X) | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname wrap | ||||||||
| setMethod( | ||||||||
| "wrap", | ||||||||
| signature(X = "matrix", bounds = "Raster", withHeading = "missing"), | ||||||||
| definition = function(X, bounds) { | ||||||||
| X <- wrap(X, bounds = extent(bounds)) | ||||||||
| return(X) | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname wrap | ||||||||
| setMethod( | ||||||||
| "wrap", | ||||||||
| signature(X = "matrix", bounds = "matrix", withHeading = "missing"), | ||||||||
| definition = function(X, bounds) { | ||||||||
| if (identical(colnames(bounds), c("min", "max")) & | ||||||||
| (identical(rownames(bounds), c("s1", "s2")))) { | ||||||||
| X <- wrap(X, bounds = extent(bounds)) | ||||||||
| return(X) | ||||||||
| } else { | ||||||||
| stop("Must use either a bbox, Raster*, or Extent for 'bounds'") | ||||||||
| } | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname wrap | ||||||||
| setMethod( | ||||||||
| "wrap", | ||||||||
| signature(X = "SpatialPointsDataFrame", bounds = "Extent", withHeading = "logical"), | ||||||||
| definition = function(X, bounds, withHeading) { | ||||||||
| if (withHeading) { | ||||||||
| # This requires that previous points be "moved" as if they are | ||||||||
| # off the bounds, so that the heading is correct | ||||||||
| X@data[coordinates(X)[, "x"] < bounds@xmin, "x1"] <- | ||||||||
| (X@data[coordinates(X)[, "x"] < bounds@xmin, "x1"] - bounds@xmin) %% | ||||||||
| (bounds@xmax-bounds@xmin) + bounds@xmax | ||||||||
| X@data[coordinates(X)[, "x"] > bounds@xmax, "x1"] <- | ||||||||
| (X@data[coordinates(X)[, "x"] > bounds@xmax, "x1"] - bounds@xmax) %% | ||||||||
| (bounds@xmin-bounds@xmax) + bounds@xmin | ||||||||
| X@data[coordinates(X)[, "y"] < bounds@ymin, "y1"] <- | ||||||||
| (X@data[coordinates(X)[, "y"] < bounds@ymin, "y1"] - bounds@ymin) %% | ||||||||
| (bounds@ymax-bounds@ymin) + bounds@ymax | ||||||||
| X@data[coordinates(X)[, "y"] > bounds@ymax, "y1"] <- | ||||||||
| (X@data[coordinates(X)[, "y"] > bounds@ymax, "y1"] - bounds@ymax) %% | ||||||||
| (bounds@ymin-bounds@ymax) + bounds@ymin | ||||||||
| } | ||||||||
| return(wrap(X, bounds = bounds)) | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname wrap | ||||||||
| setMethod( | ||||||||
| "wrap", | ||||||||
| signature(X = "SpatialPointsDataFrame", bounds = "Raster", withHeading = "logical"), | ||||||||
| definition = function(X, bounds, withHeading) { | ||||||||
| X <- wrap(X, bounds = extent(bounds), withHeading = withHeading) | ||||||||
| return(X) | ||||||||
| }) | ||||||||
| #' @export | ||||||||
| #' @rdname wrap | ||||||||
| setMethod( | ||||||||
| "wrap", | ||||||||
| signature(X = "SpatialPointsDataFrame", bounds = "matrix", withHeading = "logical"), | ||||||||
| definition = function(X, bounds, withHeading) { | ||||||||
| if ( identical(colnames(bounds), c("min", "max")) & | ||||||||
| identical(rownames(bounds), c("s1", "s2"))) { | ||||||||
| X <- wrap(X, bounds = extent(bounds), withHeading = withHeading) | ||||||||
| return(X) | ||||||||
| } else { | ||||||||
| stop("Must use either a bbox, Raster*, or Extent for 'bounds'") | ||||||||
| } | ||||||||
| }) | ||||||||
Sample Interval: 10ms
384.32MB / 29460ms
| Code | File | Calls | Memory (MB) | Time (ms) | |||
|---|---|---|---|---|---|---|---|
count | Wolf-Sheep-Predation.R | 18 | -168.2 | 28.5 | 230 | ||
set | Wolf-Sheep-Predation.R | 20 | 0 | 39.5 | 200 | ||
NLany | Wolf-Sheep-Predation.R | 7 | 0 | 15.6 | 70 | ||
of | Wolf-Sheep-Predation.R | 9 | -147.4 | 18.1 | 90 | ||
move | Wolf-Sheep-Predation.R | 109 | -4.8 | 229.9 | 1150 | ||
death | Wolf-Sheep-Predation.R | 96 | -138.5 | 152.3 | 960 | ||
NLwith | Wolf-Sheep-Predation.R | 79 | 0 | 176.0 | 830 | ||
growGrass | Wolf-Sheep-Predation.R | 414 | -645.5 | 930.3 | 4370 | ||
catchSheep | Wolf-Sheep-Predation.R | 349 | -618.8 | 713.0 | 3870 | ||
reproduce | Wolf-Sheep-Predation.R | 863 | -1999.9 | 1669.1 | 9680 | ||
which | Wolf-Sheep-Predation.R | 4 | 0 | 7.0 | 40 | ||
runif | Wolf-Sheep-Predation.R | 3 | 0 | 5.4 | 30 | ||
count | Wolf-Sheep-Predation.R | 5 | 0 | 9.9 | 50 | ||
right | Wolf-Sheep-Predation.R | 19 | -303.6 | 33.8 | 220 | ||
fd | Wolf-Sheep-Predation.R | 78 | 0 | 161.3 | 790 | ||
set | Wolf-Sheep-Predation.R | 217 | -601.5 | 354.4 | 2170 | ||
hatch | Wolf-Sheep-Predation.R | 417 | -627.9 | 739.4 | 4300 | ||
standardGeneric | turtle-functions.R | 417 | -627.9 | 739.4 | 4300 | ||
loadMethod | 4 | 0 | 5.4 | 40 | |||
hatch | 407 | -627.9 | 724.6 | 4200 | |||
nrow | turtle-functions.R | 3 | 0 | 5.3 | 30 | ||
rownames<- | turtle-functions.R | 2 | 0 | 3.6 | 20 | ||
[<- | turtle-functions.R | 11 | 0 | 18.5 | 130 | ||
[ | turtle-functions.R | 14 | 0 | 22.2 | 140 | ||
$ | turtle-functions.R | 3 | 0 | 5.0 | 30 | ||
match | turtle-functions.R | 6 | 0 | 10.1 | 60 | ||
rbind | turtle-functions.R | 95 | 0 | 156.2 | 960 | ||
SpatialPointsDataFrame | turtle-functions.R | 272 | -627.9 | 496.9 | 2790 | ||
coordinates | 3 | 0 | 5.4 | 30 | |||
is | 5 | 0 | 8.4 | 50 | |||
SpatialPoints | 136 | -175.7 | 242.4 | 1380 | |||
.bboxCoords | 20 | 0 | 35.1 | 200 | |||
new | 115 | -175.7 | 205.4 | 1170 | |||
new | 125 | -452.2 | 235.9 | 1300 | |||
getClass | 1 | 0 | 1.7 | 10 | |||
initialize | 123 | -452.2 | 232.7 | 1280 | |||
of | Wolf-Sheep-Predation.R | 43 | 0 | 90.8 | 430 | ||
turtle | Wolf-Sheep-Predation.R | 141 | -466.9 | 257.8 | 1600 | ||
eatGrass | Wolf-Sheep-Predation.R | 499 | -1342.9 | 1189.6 | 7970 | ||
count | Wolf-Sheep-Predation.R | 3 | 0 | 4.2 | 30 | ||
of | Wolf-Sheep-Predation.R | 2 | 0 | 3.5 | 20 | ||
patchHere | Wolf-Sheep-Predation.R | 41 | 0 | 38.5 | 410 | ||
NLwith | Wolf-Sheep-Predation.R | 86 | -2.1 | 190.1 | 910 | ||
set | Wolf-Sheep-Predation.R | 258 | -301.1 | 288.5 | 2670 | ||
standardGeneric | agentset-functions.R | 258 | -301.1 | 288.5 | 2670 | ||
set | 256 | -301.1 | 286.4 | 2650 | |||
turtlesOn | Wolf-Sheep-Predation.R | 375 | -1039.6 | 661.1 | 3910 | ||
☒ Hide internal function calls
☒ Hide lines of code with zero time
☐ Hide memory results